diff --git a/README b/README
new file mode 100644
index 0000000..4181c15
--- /dev/null
+++ b/README
@@ -0,0 +1,13 @@
+ chez-openbsd - mirror of ChezScheme with OpenBSD boot files
+=============================================================
+
+THIS REPO IS A MIRROR OF https://github.com/cisco/ChezScheme CONTAINING OPENBSD BOOT FILES.
+I am not the owner of ChezScheme nor a developer of ChezScheme.
+Please send issues related to ChezScheme directly to their Github repo.
+You'll find a copy of the original README in README.md.
+
+To build on OpenBSD, simply do `./configure --threads` and `gmake -jN`,
+`--threads` enabling posix thread support and N in `-jN` being the number of cores in your system.
+
+See https://git.heimdall.pm/chez-openbsd/releases for releases.
+See https://heimdall.pm/blog/2022/07/28/how-to-build-chezscheme-on-openbsd.html for more information.
diff --git a/README.md b/README.md
index 633c955..65aaf2a 100644
--- a/README.md
+++ b/README.md
@@ -1,17 +1,60 @@
-# chez-openbsd - mirror of ChezScheme with OpenBSD boot files
-## ChezScheme v9.5.9
-
-**THIS REPO IS A MIRROR OF [CHEZSCHEME](https://github.com/cisco/ChezScheme) CONTAINING OPENBSD BOOT FILES.**
-I am not the owner of ChezScheme nor a developer of ChezScheme.
-Please send issues related to ChezScheme directly to their [Github repo](https://github.com/cisco/ChezScheme).
-You'll find a copy of the original README in `README.original.md`.
-
-To build on OpenBSD, simply do:
-```bash
-$ ./configure --threads
-$ gmake -jN
-```
-`--threads` enables (posix) thread support and the `N` in `-jN` being the number of cores in your system.
-
-See [releases](https://basedwa.re/tmtt/chez-openbsd/releases).
-See [the original blogpost](https://heimdall.pm/blog/2022/07/28/how-to-build-chezscheme-on-openbsd.html) for more information.
+[](https://github.com/cisco/ChezScheme/actions/workflows/test.yml)
+
+Chez Scheme is both a programming language and an implementation
+of that language, with supporting tools and documentation.
+
+As a superset of the language described in the
+[Revised6 Report on the Algorithmic Language Scheme](http://www.r6rs.org)
+(R6RS), Chez Scheme supports all standard features of Scheme,
+including first-class procedures, proper treatment of tail calls,
+continuations, user-defined records, libraries, exceptions, and
+hygienic macro expansion.
+
+Chez Scheme also includes extensive support for interfacing with C
+and other languages, support for multiple threads possibly running
+on multiple cores, non-blocking I/O, and many other features.
+
+The Chez Scheme implementation consists of a compiler, run-time
+system, and programming environment.
+Although an interpreter is available, all code is compiled by
+default.
+Source code is compiled on-the-fly when loaded from a source file
+or entered via the shell.
+A source file can also be precompiled into a stored binary form and
+automatically recompiled when its dependencies change.
+Whether compiling on the fly or precompiling, the compiler produces
+optimized machine code, with some optimization across separately
+compiled library boundaries.
+The compiler can also be directed to perform whole-program compilation,
+which does full cross-library optimization and also reduces a
+program and the libraries upon which it depends to a single binary.
+
+The run-time system interfaces with the operating system and supports,
+among other things, binary and textual (Unicode) I/O, automatic
+storage management (dynamic memory allocation and generational
+garbage collection), library management, and exception handling.
+By default, the compiler is included in the run-time system, allowing
+programs to be generated and compiled at run time, and storage for
+dynamically compiled code, just like any other dynamically allocated
+storage, is automatically reclaimed by the garbage collector.
+
+The programming environment includes a source-level debugger, a
+mechanism for producing HTML displays of profile counts and program
+"hot spots" when profiling is enabled during compilation, tools for
+inspecting memory usage, and an interactive shell interface (the
+expression editor, or "expeditor" for short) that supports multi-line
+expression editing.
+
+The R6RS core of the Chez Scheme language is described in
+[The Scheme Programming Language](http://www.scheme.com/tspl4/),
+which also includes an introduction to Scheme and a set of example programs.
+Chez Scheme's additional language, run-time system, and
+programming environment features are described in the
+[Chez Scheme User's Guide](http://cisco.github.io/ChezScheme/csug9.5/csug.html).
+The latter includes a shared index and a shared summary of forms,
+with links where appropriate to the former, so it is often the best
+starting point.
+
+Get started with Chez Scheme by [Building Chez Scheme](BUILDING).
+
+For more information see the [Chez Scheme Project Page](https://cisco.github.io/ChezScheme/).
diff --git a/README.original.md b/README.original.md
deleted file mode 100644
index 65aaf2a..0000000
--- a/README.original.md
+++ /dev/null
@@ -1,60 +0,0 @@
-[](https://github.com/cisco/ChezScheme/actions/workflows/test.yml)
-
-Chez Scheme is both a programming language and an implementation
-of that language, with supporting tools and documentation.
-
-As a superset of the language described in the
-[Revised6 Report on the Algorithmic Language Scheme](http://www.r6rs.org)
-(R6RS), Chez Scheme supports all standard features of Scheme,
-including first-class procedures, proper treatment of tail calls,
-continuations, user-defined records, libraries, exceptions, and
-hygienic macro expansion.
-
-Chez Scheme also includes extensive support for interfacing with C
-and other languages, support for multiple threads possibly running
-on multiple cores, non-blocking I/O, and many other features.
-
-The Chez Scheme implementation consists of a compiler, run-time
-system, and programming environment.
-Although an interpreter is available, all code is compiled by
-default.
-Source code is compiled on-the-fly when loaded from a source file
-or entered via the shell.
-A source file can also be precompiled into a stored binary form and
-automatically recompiled when its dependencies change.
-Whether compiling on the fly or precompiling, the compiler produces
-optimized machine code, with some optimization across separately
-compiled library boundaries.
-The compiler can also be directed to perform whole-program compilation,
-which does full cross-library optimization and also reduces a
-program and the libraries upon which it depends to a single binary.
-
-The run-time system interfaces with the operating system and supports,
-among other things, binary and textual (Unicode) I/O, automatic
-storage management (dynamic memory allocation and generational
-garbage collection), library management, and exception handling.
-By default, the compiler is included in the run-time system, allowing
-programs to be generated and compiled at run time, and storage for
-dynamically compiled code, just like any other dynamically allocated
-storage, is automatically reclaimed by the garbage collector.
-
-The programming environment includes a source-level debugger, a
-mechanism for producing HTML displays of profile counts and program
-"hot spots" when profiling is enabled during compilation, tools for
-inspecting memory usage, and an interactive shell interface (the
-expression editor, or "expeditor" for short) that supports multi-line
-expression editing.
-
-The R6RS core of the Chez Scheme language is described in
-[The Scheme Programming Language](http://www.scheme.com/tspl4/),
-which also includes an introduction to Scheme and a set of example programs.
-Chez Scheme's additional language, run-time system, and
-programming environment features are described in the
-[Chez Scheme User's Guide](http://cisco.github.io/ChezScheme/csug9.5/csug.html).
-The latter includes a shared index and a shared summary of forms,
-with links where appropriate to the former, so it is often the best
-starting point.
-
-Get started with Chez Scheme by [Building Chez Scheme](BUILDING).
-
-For more information see the [Chez Scheme Project Page](https://cisco.github.io/ChezScheme/).
diff --git a/csug/canned/csug.css b/csug/canned/csug.css
deleted file mode 100644
index 083ce26..0000000
--- a/csug/canned/csug.css
+++ /dev/null
@@ -1,35 +0,0 @@
-BODY {background-color: #FFFFFF}
-
-a:link, a:active, a:visited { color:#005568; text-decoration:underline }
-a:hover { color:white; text-decoration:underline; background:#005568 }
-
-a.plain:link, a.plain:active, a.plain:visited { color:#005568; text-decoration:none }
-a.plain:hover { color:white; text-decoration:none; background:#005568 }
-
-a.toc:link, a.toc:active, a.toc:visited {font-family: sans-serif; color:#005568; text-decoration:none}
-a.toc:hover {font-family: sans-serif; color:white; text-decoration:none; background:#005568}
-
-a.image:link, a.image:active, a.image:visited, a.image:hover {
- color: #005568;
- background: #FFFFFF;
-}
-
-ul.tocchapter { list-style: none; }
-ul.tocsection { list-style: circle; color: #C41230 }
-
-hr.copyright { width: 50% }
-
-input.default { background: #ffffff; color: #000000; vertical-align: middle}
-
-h1, h2, h3, h4 {font-family: sans-serif; color: #005568}
-h1 {font-size: 2em}
-h2 {margin-top: 30px; font-size: 1.5em}
-h3 {margin-top: 30px; font-size: 1.17em}
-h1, h2, h3, h4 {font-weight: bold}
-
-.title { font-family: sans-serif; font-weight: bold; font-size: 2.5em; color: #005568; white-space: nowrap}
-
-.formdef { color: #005568 }
-
-table.indent {margin-left: 20px}
-
diff --git a/csug/canned/csug.css b/csug/canned/csug.css
new file mode 120000
index 0000000..69b665c
--- /dev/null
+++ b/csug/canned/csug.css
@@ -0,0 +1 @@
+../csug.css
\ No newline at end of file
diff --git a/ta6ob/LOG b/ta6ob/LOG
deleted file mode 100644
index 1b3f7b6..0000000
--- a/ta6ob/LOG
+++ /dev/null
@@ -1,2341 +0,0 @@
-9.4 changes:
-- updated version to 9.4
- bintar README NOTICE makefiles/Mf-install.in scheme.1.in
- c/Makefile.i3nt c/Makefile.a6nt c/Makefile.ti3nt c/Makefile.ta6nt
- mats/bldnt.bat workarea c/scheme.rc s/7.ss s/cmacros.ss
- release_notes/release_notes.stex csug/csug.stex
-- added missing include
- killme.c
-- added new mat verifying that primitives raise exceptions for invalid
- arguments based on primdata.ss signatures. fixed some of those
- signatures, which weren't otherwise used except for arity checking.
- fixed some issues turned up by the test with who reports errors
- and how.
- primdata.ss, 5_1.ss, 7.ss, compile.ss, cpnanopass.ss, fasl.ss,
- interpret.ss, io.ss, record.ss, syntax.ss,
- primvars.ms, 5_1.ms, 7.ms, 8.ms, record.ms, mats/Mf-base,
- root-experr*, patch*
-- string comparisons (string=?, string-cidate test in mat time&date-printing to work regardless of
- what locale (and time zone) the host machine has set.
- date.ms
-- fixed date->time-utc to honor the zone-offset field when converting a date
- object to a time-utc object.
- stats.c,
- date.ms
-- fixed incorrect handling of library-extension when searching wpo files
- compile.ss,
- 7.ms
-- modified floatify_normalize to properly round denormalized results.
- obviated scale_float in the process.
- number.c,
- ieee.ms
-- fixed 0eNNNN for large NNNN to produce 0.0 rather than infinity
- strnum.ss,
- 5_3.ms
-- the reader now raises an exception with condition type implementation
- restriction (among the other usual lexical condition types), and
- string->number now raises #f, for #e@, where and are
- nonzero integers, since Chez Scheme can't represent polar numbers other
- than 0@ and @0 exactly. @ still produces an inexact result,
- i.e., we're still extending the set of inexact numeric constants beyond
- what R6RS dictates. doing this required a rework of $str->num, which
- turned into a fairly extensive rewrite that fixed up a few other minor
- issues (like r6rs:string->number improperly allowing 1/2e10) and
- eliminated the need for consumers to call $str->num twice in cases
- where it can actually produce a number. added some related new tests,
- including several found missing by profiling. added a couple of
- checks to number->string the absence of which was causing argument
- errors to be reported by other routines.
- strnum.ss, exceptions.ss, read.ss
- 5_3.ms, 6.ms, root-experr*, patch*
-- added pdhtml flag, which if set to t causes profile-dump-html to be
- called at the end of a mat run.
- mats/Mf-base
-- compile-whole-program and compile-whole-library now copy the hash-bang
- line from the wpo file (if it has one) to the object file.
- compile.ss,
- 7.ms
-- stex is now a submodule. csug/Makefile and release_notes/Makefile
- set and use the required Scheme and STEXLIB variables accordingly.
- they default the machine type to a6le, but this can be overridden
- and is by the generated top-level Makefile. the generated top-level
- Makefile now has a new docs target that runs make in both csug and
- release_notes, and an updated distclean target that cleans the same.
- the annoying csug Makefile .fig.pdf rule redefinition is now gone.
- copyright.stex and csug.stex now list May 2016 as the revision month
- and date; this will have to be updated for future releases.
- configure, makefiles/Makefile.in,
- csug/Makefile, copyright.stex, csug.stex,
- release_notes/Makefile
-- added custom install options. workarea creates an empty config.h,
- and configure creates a config.h that sets the default scheme heap
- path and scheme-script name based on the actual configuration.
- configure, newrelease, workarea, checkin,
- c/Mf-base, scheme.c, main.c,
- Mf-install.in
-- renamed the installed example directory from lib to examples.
- Mf-install.in,
- scheme.1.in
-- added force option to gzip during man page install to prevent gzip from
- asking for permission to overwrite existing man page files.
- Mf-install.in
-- removed ~/lib/csv%v/%m from the default scheme heap path on unix-like
- systems. documented inclusion of %x\..\..\boot\%m in the Windows
- default scheme heap path.
- main.c,
- use.stex
-- added new configuration options: --installbin, --installlib,
- --installschemename, --installpetitename, and --installscriptname.
- configure
-- updated the example library link to the nanopass framework.
- CONTRIBUTING.md
-- now cleaning up petite.1 and scheme.1 left behind by make install
- Makefile-workarea.in, checkin
-- now removing workarea after cleaning csug and release_notes so
- Mf-stex (included from csug/Makefile and release_notes/Makefile)
- doesn't complain trying to determine the machine type.
- Makefile.in
-- added installsh support for --ifdiff so the csug make file can use it
- for the install target.
- installsh,
- csug/Makefile
-- added instructions for building (cross-compiling) a boot file for
- a supported machine type for which a boot file is not built by default.
- BUILDING
-- corrected CHEZSCHEMELIBS and CHEZSCHEMEEXTS index entries to be
- CHEZSCHEMELIBDIRS and CHEZSCHEMELIBEXTS.
- use.stex
-- updated to curl stex version 1.2.1
- configure
-- updated the fix to S_mktime to work on windows. the struct tm
- structure on windows does not have the tm_gmtoff field used in the
- mac and linux version of the code.
- stats.c
-- updated the Windows makefiles for building and testing to remove links for
- files that no longer exist, which was getting in the way of creating links
- for files that do exist. Also updated the build batch file for Windows to
- compile the nanopass framework separately before building the rest of the
- scheme compiler and libraries.
- s/Mf-{a6,i3,ta6,ti3}nt, s/bldnt.bat,
- mats/Mf-{a6,i3,ta6,ti3}nt
-- updated the read me to include a link to the Chez Scheme project page.
- README.md
-- fixed embarrassing typo in read me.
- README.md
-- profiler's html output refresh: mark the files as HTML5 rather
- than HTML4; use target attributes rather than onclick events to
- open links in specific windows; add a missing table row element;
- replace the deprecated name attribute with an id attribute (and
- replace the anchors with spans); and replace the deprecated valign
- attribute with a style attribute.
- pdhtml.ss
-
-9.4.1 changes:
-- updated version to 9.4.1
- bintar BUILDING NOTICE makefiles/Mf-install.in scheme.1.in
- c/Makefile.i3nt c/Makefile.a6nt c/Makefile.ti3nt c/Makefile.ta6nt
- mats/bldnt.bat workarea c/scheme.rc s/7.ss s/cmacros.ss
- release_notes/release_notes.stex csug/csug.stex
-- updated newrelease to produce the correct log-entry format and
- fixed the existing 9.4.1 log entry
- newrelease, LOG
-- replaced a couple of tabs
- number.c
-- updated the descriptions of statistics and related functions to
- reflect the Version 9.3.1 change from sstats structures to sstats
- records, with sstats times represented as time objects and sstats
- bytes and counts represented as exact integers; also updated the
- sstats-difference description to reflect that it no longer coerces
- negative differences to zero. added a corresponding release note.
- system.stex,
- release_notes.stex
-- added a cast to eliminate a warning
- c/number.c
-- fixed bug in Windows version of directory-separator-predicate when
- path-* procedures are passed a path that is not a string.
- s/6.ss
-- fixed bug in cp0 on Windows with $foreign-wchar?.
- s/cp0.ss
-- Cygwin is now used on Windows, updated mats, eliminated unused killme
- BUILDING c/*nt c/Mf-base c/scheme.exe.manifest configure
- examples/Makefile mats/6.ms mats/Mf-* mats/foreign.ms mats/ftype.ms
- mats/patch-* mats/windows.ms s/Mf-*nt s/Mf-base workarea
- release_notes.stex
-- fixed spelling of non-existent
- s/syntax.ss
-- now forcing zlib configuration before compiling files that depend on
- the zlib header files, since zlib's configure script can modify the
- header files. removed ZlibInclude variable, which no longer serves
- a purpose.
- c/Mf-*, c/Makefile.*nt
-- removed unnecessary datestamp.c target
- c/Mf.*nt
-- fixed unnecessary blocking in expeditor on Windows.
- c/expeditor.c
-- eliminated a couple of thread-safety issues and limitations on the
- sizes of pathnames produced by expansion of tilde (home-directory)
- prefixes by replacing S_pathname, S_pathname_impl, and S_homedir
- with S_malloc_pathname, which always mallocs space for the result.
- one thread-safety issue involved the use of static strings for expanded
- pathnames and affected various file-system operations. the other
- affected the file open routines and involved use of the incoming
- pathname while deactivated. the incoming pathname is sometimes if not
- always a pointer into a Scheme bytevector, which can be overwritten if a
- collection occurs while the thread is deactivated. the size limitation
- corresponded to the use of the static strings, which were limited to
- PATH_MAX bytes. (PATH_MAX typically isn't actually the maximum path
- length in contemporary operating systems.) eliminated similar issues
- for wide pathnames under Windows by adding S_malloc_wide_pathname.
- consumers of the old routines have been modified to use the new
- routines and to free the result strings. the various file operations
- now consistently treat a pathname with an unresolvable home directory
- as a pathname that happens to start with a tilde. eliminated unused
- foreign-symbol binding of "(cs)pathname" to S_pathname.
- io.c, externs.h, new_io.c, prim5.c, scheme.c, prim.c
-- various places where a call to close or gzclose was retried when
- the close operation was interrupted no longer do so, since this can
- cause problems when another thread has reallocated the same file
- descriptor.
- new_io.c
-- now using vcvarsall type x86_amd64 rather than amd64 when the
- former appears to supported and the latter does not, as is the
- case with VS Express 2015.
- c/Mf-a6nt, c/Mf-ta6nt
-- commented out one of the thread mats that consistently causes
- indefinite delays under Windows and OpenBSD due to starvation.
- thread.ms
-- increased wait time for a couple of subprocess responses
- 6.ms
-- added call to collector to close files opened during iconv mats
- specifically for when mats are run under Windows with no iconv dll.
- io.ms
-- fixed typo: VC/bin/vcvars64.bat => VC/bin/amd64/vcvars64.bat
- c/Mf-a6nt, c/Mf-ta6nt
-- scheme_mutex_t now uses volatile keyword for owner and count fields
- because these fields can be accessed from multiple threads
- concurrently. Updated $yield and $thread-check in mats/thread.ms to
- be more tolerant of timing variability.
- c/types.h, mats/thread.ms, release_notes.stex
-- fixed three instances of unchecked mallocs reported by laqrix in
- github issue #77.
- io.c, schlib.c, thread.c
-- continue the profiler's html output refresh: refine the styling
- (and palette) and update CSUG to match. update the CSUG screenshots
- to reflect the refined look.
- s/pdhtml.ss
- csug/system.stex
- csug/canned/profilehtml-orig.png
- csug/canned/profilehtml.png
- csug/canned/fatfibhtml-orig.png
- csug/canned/fatfibhtml.png
-- add unicode support to the expression editor. entry and display now work
- except that combining characters are not treated correctly for
- line-wrapping. this addresses github issue #32 and part of issue #81.
- c/expeditor.c, s/expeditor.ss
-- moved s_ee_write_char function within the WIN32 check to allow the unicode
- change to compile on windows. unicode is not yet supported in the windows
- version of the repl.
- c/expeditor.c
-- reworked the S_create_thread_object to print an error and exit when
- allocating the thread context fails from Sactivate_thread. before
- this change, the error was raised on the main thread, which resulted
- in strange behavior at best. also added who argument to
- S_create_thread_object to allow it to report either Sactivate_thread
- or fork-thread led to the error.
- externs.h, schsig.c, scheme.c, thread.c
-- fixed a bug in cpvalid resulting in it leaving behind a cpvalid-defer
- form for later passes to choke on. also fixed cp0 to print the correct
- name for cpvalid when it does this.
- cpvalid.ss, cp0.ss,
- misc.ms
-- updated the prototype for s_ee_write_char to match the definition
- expeditor.c
-- fixed a side-effect preservation bug with non-trivial test-context
- not-like patterns.
- cp0.ss,
- cp0.ms, 4.ms
-- instead of default-exception handler, new-cafe establishes a handler
- that calls the current value of base-exception-handler so the handler
- can be overridden, as we do in our own make files.
- cafe.ss,
- 7.ms
-- fixed a bug in case and exclusive-cond syntax-error calls causing an
- exception in syntax-error instead of the intended error message.
- syntax.ss
-- added tests for the case and exclusive-cond syntax-error calls
- 4.ms, root-experr-compile-0-f-f-f
-- added print-extended-identifiers parameter. when #t, symbols like
- 1+ and +++ print without escapes.
- priminfo.ss, print.ss,
- 6.ms
-- added descriptions of print-extended-identifiers to the user's guide
- and release notes. updated the release notes to account for a couple
- of other log entries.
- release_notes.stex,
- intro.stex, io.stex
-- updated the sockets example to work with the current version of Chez.
- Change the foreign procedure definitions to use the more portable int
- rather than integer-32. Switch to a custom port
- [make-custom-binary-input/output-port] rather than a generic port
- [make-input/output-port], which resulted in deleting quite a bit of
- code. Fix various compiler warnings in the C code, and along the way,
- fix a signedness bug in c_write that could have resulted in not writing
- the full buffer (but reporting that it did) in the case of errors from
- write.
- examples/csocket.c, examples/socket.ss
-- use high-precision clock time on Windows 8 and up
- c/stats.c
-- fixed profiling code that keyed profiling locations off of only the
- bfp to instead key off of both the bfp and efp.
- pdhtml.ss
-- added Windows installer using the WiX Toolset
- BUILDING, install/* (new)
-- fix typo in ordinal format for 12
- format.ss,
- format.ms
-- renamed install directory to wininstall to avoid conflict with
- top-level Makefile
- BUILDING, install/* (removed), wininstall/* (new)
-- updated zlib to version 1.2.11
- configure
-- added procedure-arity-mask to report the allowed argument counts of
- a compiled function. On a procedure from interpret or from one of
- the trace procedures or syntactic forms, procedure-arity-mask
- may report counts that are not actually allowed by the source
- procedure.
- cmacros.ss, compile.ss, cpnanopass.ss, mkheader.ss, primdata.ss,
- prims.ss, strip.ss,
- fasl.c, gc.c, globals.h, prim.c, prim5.c, scheme.c, schsig.c,
- misc.ms, root-experr*,
- objects.stex
-- for non-win32 systems, now setting al register to a count of the
- floating-point register arguments as required for varargs functions
- by the System V ABI.
- x86_64.ss,
- foreign.ms
-- added a missing quote mark in new printf mat Windows case
- foreign.ms
-- added travis-ci automation script and a 'partialx' testing target to
- allow us to perform more than a single run of testing without running
- afoul of travis-ci's 50-minute build timeout. 'partialx' tests six
- of the twelve configurations tested by 'allx'.
- .travis.yml (new),
- mats/Mf-base
-- paired the 'partialx' down to just four test configurations, with one
- interpreter run, to try to get the threaded builds into line with
- travis-ci's timeout.
- mats/Mf-base
-- eliminated some direct assumptions that a vector's type/length field
- is a fixnum and added meta-asserts to verify that it is in a couple of
- others, to facilitate future changes to vector typing. vectors are
- now treated essentially like fxvectors, strings, and bytevectors.
- cmacros.ss, cpnanopass.ss, prims.ss, mkheader.ss,
- alloc.c, gc.c, scheme.c
-- fixed a few comments to refer to scheme.c rather than main.c
- externs.h, globals.h, thread.c
-- for 64-bit Windows systems, now copying foreign-procedure
- double-precision floating-point register arguments to integer
- registers as required for varargs functions. Windows does not
- support single-precision floating-point arguments as varargs.
- foreign.ms, np-languages.ss, x86_64.ss
-- added an optional timeout argument to condition-wait
- externs.h, stats.c, thread.c, thread.h, csug/threads.stex,
- primvars.ms, thread.ms, release_notes.stex,
- date.ss, primdata.ss, prims.ss
-- added immutable strings, vectors, fxvector, bytevectors, and boxes
- 5_4.ss, 5_6.ss, bytevector.ss, cmacros.ss, cpnanopass.ss,
- fasl.ss, library.ss, mkheader.ss, primdata.ss, prims.ss,
- externs.h, types.h, alloc.c, fasl.c, gc.c, scheme.c,
- 5_5.ms, 5_6.ms, bytevector.ms, misc.ms, root-experr*
- objects.stex
-- various tweaks to the immutable object support; also taught cp0
- to simplify ($fxu< (most-positive-fixnum) e) => (fx< e 0) so we
- don't have any incentive in special casing length checks where
- the maximum length happens to be (most-positive-fixnum).
- 5_4.ss, 5_6.ss, bytevector.ss, cmacros.ss, cp0.ss, cpnanopass.ss,
- mkheader.ss, primdata.ss, prims.ss,
- fasl.c, gc.c, types.h
- root-experr*, patch*
-- generated bytevector=? procedure now gets out quickly on eq
- arguments. cp0 optimizes away a number of additional equality
- operations at optimize-level 3 (including bytevector=?) when
- applied to the same variable references, as it already did for
- eq?, eqv?, and equal?, at all optimize levels.
- cpnanopass.ss, cp0.ss, primdata.ss,
- cp0.ms
-- updated bullyx patches
- patch*
-- updated release notes and tweaked user's guide.
- release-notes.stex, objects.stex
-- fixed typo: fxvector-immutable-flag used in place of
- bytevector-immutable-flag in computation of type-immutable-bytevector
- cmacros.ss
-- reallocated typed-object types, using previously unused tag #b010
- for strings and giving bytevectors both #b001 and #b101 (the
- latter for immutable bytevectors) so that the maximum bytevector
- length on 32-bit machines is once again the most-positive fixnum.
- treating bytevectors rather than strings or fxvectors (or even
- vectors) special in this regard is appropriate since the maximum
- number of bytes in a bytevector is maximum-length x 1 rather than
- maximum-length x 4 for strings, fxvectors, and vectors on 32-bit
- machines. with this change on 32-bit machines, a vector can
- occupy up to 1/2 of virtual memory, strings and fxvectors 1/4,
- and bytevectors 1/8.
- cmacros.ss
-- added record-type-equal-procedure, record-type-hash-procedure,
- record-equal-procedure, and record-hash-procedure to enable
- per-type customization of the behavior of equal? and equal-hash
- for a record value
- 5_1.ss, newhash.ss, primdata.ss,
- record.ms, root-experr*,
- objects.stex
-- adding dropped changes
- record.ss,
- root-experr*
-- added entry for record-type-equal-procedure and friends
- release_notes.stex
-- changed copyright year to 2017
- 7.ss, scheme.1.in, comments of many files
-- expanded the CSUG description of the handling of command-line
- arguments not recognized as standard options and added a description
- of the same to the COMMAND-LINE OPTIONS section of the man page.
- did a bit of minor cleanup elsewhere in the man page.
- use.stex, scheme.1.in
-- destroy_thread now processes guardian entries
- thread.c, 4.ms, release_notes.stex
-- mutexes and conditions are now freed when no longer used via
- $close-resurrected-mutexes&conditions, $keep-live primitive added
- externs.h, prim5.c, thread.c, 4.ms, thread.ms, release_notes.stex,
- 7.ss, cpnanopass.ss, np-languages.ss, primdata.ss, prims.ss
-- fix reduction for map and for-each with optimization level 3
- to drop the expression, check that procedure has the correct
- arity and is discardable or unsafe.
- Also add a simplification for for-each with empty lists
- with optimization level 2.
- cp0.ss, 4.ms, primdata.ss
-- fix invalid memory reference when enum-set-indexer procedure is not
- passed a symbol
- enum.ss, enum.ms, root-experr*, release_notes.stex
-- fix overflow detection for fxsll, fxarithmetic-shift-left, and
- fxarithmetic-shift
- library.ss, fx.ms, release_notes.stex
-- added ephemeron pairs and changed weak hashtables to use
- ephemeron pairs for key--value mapping to avoid the key-in-value
- problem
- prims.ss, primdata.ss, newhash.ss, fasl.ss, mkheader.ss
- cmacro.ss, prim5.c, fasl.c, gc.c, gcwrapper.c, types.h,
- 4.ms, hash.ms, objects.stex, smgmt.stex, csug.bib
-- check_dirty_ephemeron now puts ephemerons whose keys haven't yet
- been seen on the pending list rather than the trigger lists.
- gc.c
-- removed scan of space_ephemeron from check_heap because check_heap
- as written can't handle the two link fields properly.
- gcwrapper.c
-- in the ephemerons mat that checks interaction between mutation and
- collection, added generation arguments to the first two collect
- calls so they always collect into the intended generation.
- 4.ms
-- updated allx and bullyx patches
- patch*
-- fix strip-fasl-file for immutable strings and vectors,
- fix an $oops call, and fix a vector-index increment in hashing
- strip.ss, 7.ss, newhash.ss, misc.ms
-- fix signature of fxbit-set?
- primdata.ss
-- more optimizations for map and for-each with explicit list
- extend the reductions for map and for-each when the arguments are
- explicit lists like (list 1 2 3 ...) or '(1 2 3 ...).
- cp0.ss,
- 4.ms
-- reverted to the preceding version of cp0 due to failure to preserve
- the expected evaluation order in one of the mats; removed the
- corresponding equivalent-expansion tests.
- cp0.ss,
- 4.ms
-- restored the map and for-each optimizations with a fix for the
- evaluation-order bug.
- cp0.ss,
- 4.ms
-- added date-dst? to access the previously-hidden DST information in
- date records, and added date-zone-name to provide a time zone name.
- date.ss, primdata.ss,
- stats.c,
- date.ms, root-experr*, patch-compile*,
- system.stex
-- fixed a bug in flonum-extractor, which on 64-bit machines was using an
- 8-byte read instead of a 4-byte read to pick up the 4 highest-order
- bytes of a little-endian flonum, potentially reading past the end of
- mapped memory for flonums produced by taking the imaginary part of an
- inexact complexnum (which, unlike other flonums, are not aligned on
- 16-byte boundaries). The 8-byte load would also have failed to produce
- correct results on 64-bit big-endian machines (of which we presently
- have none) because the offsets passed to flonum-extractor assume the
- bits are in the lowest-order 4 bytes of the extracted field.
- cp0.ss,
- misc.ms,
- release_notes.stex
-- support Windows build on Bash/WSL
- BUILDING, configure, workarea, c/vs.bat (new), mats/vs.bat (new),
- c/Mf-*nt, mats/Mf-*, s/Mf-base
-- fix c/version.h for FreeBSD (machine types i3fb, ti3fb, a6fb, ta6fb)
-- fix reference to libc.so to be libc.so.7 for FreeBSD (machine types
- i3fb, ti3fb, a6fb, ta6fb)
- foreign.ms
-- added CC option to configure for selecting the compiler
- configure,
- c/Mf-*
-- Suppress warnings from implicit fall-through in case labels.
- Mf-{a6,arm32,i3,ppc,ta6,ti3,tpp32}le
-- added bytevector-compress and bytevector-uncompress
- bytevector.ss, primdata.ss, new-io.c, prim5.c, externs.h,
- objects.stex, release_notes.stex,
- bytevector.ms, root-experr*
-- fixed typo in S_abnormal_exit
- schsig.c
-- don't remove the pariah form in the cp0 pass
- cp0.ss,
- misc.ms
-- revert use of ephemerons in weak hashtables, add ephemeron
- hashtables
- newhash.ss, hashtable-types.ss, library.ss, primdata.ss,
- fasl.ss, fasl.c, gc.c, globals.h,
- hash.ms, objects.stex, release_notes.stex
-- fixed pariah mat
- misc.ms
-- minor wordsmithing and fix for an overfull hbox
- objects.stex, system.stex
-- fix (define-values () ....) to expand to a definition
- syntax.ss, 3.ms
-- added optional line and column components to a source object, a
- locate-source-object-source function that uses the new components,
- a current-locate-source-object-source parameter to control looking up
- line and column information, a current-make-source-object parameter to
- control location recording, an optional use-cache argument to
- locate-source, and a 'source-object message for code and continuation
- inspectors
- read.ss, syntax.ss, 7.ss, compile.ss, cpnanopass.ss, exceptions.ss,
- inspect.ss, primdata.ss, prims.ss, print.ss, cmacros.ss, types.ss,
- mat.ss, 8.ms, root-experr*,
- syntax.stex, debug.stex, system.stex, release_notes.stex
-- fixed broken mats on Windows caused by Bash/WSL changes
- 7.ms, ftype.ms
-- added "ez-grammar" example program
- examples/ez-grammar.ss, examples/ez-grammar-test.ss,
- examples/Makefile, examples.ms
-- updated ez-grammar-test to write temp files to current directory and delete them when finished
- examples/ez-grammar-test.ss
-- added support for Microsoft Visual Studio 2017 on Windows
- BUILDING, c/Mf-a6nt, c/Mf-ta6nt, c/vs.bat,
- mats/Mf-a6nt, mats/Mf-ta6nt, mats/ftype.ms
-- added support for building Windows installs with Bash/WSL
- wininstall/Makefile, candle.bat, light.bat
-- added support for building with Visual Studio 2017's BuildTools
- c/vs.bat
-- check for git before using to get submodules
- configure
-- fixed windows installer failure when vcredist is not preinstalled by
- using the vcredist merge module, split the 32 and 64 bit MSIs and
- added a wix bundle to combine the MSIs into a single exe installer,
- added a batch script for locating Visual Studio's vcredist merge
- modules, updated installer paths and names.
- wininstall/*
-- fixed np-normalize-context pass to process trivs list in mvset forms
- in tail and predicate context and added regression tests. Thanks to
- @marcomaggi for reporting the bug and @yjqww6 for providing a
- simplified test and finding the initial solution.
- cpnanopass.ss,
- 3.ms
-- removed a useless check in foreign-alloc
- record.ss
-- fix cp0 reduction of fx[+-*]/carry and their signatures
- cp0.ss
- primdata.ss
- fx.ms
-- renamed s_gettime => S_gettime to remain consistent with the
- convention that the only undocumented externs are prefixed with
- S_.
- externs.h, stats.c, thread.c
-- added version number to scheme.1.in trailer; updated date.
- scheme.1.in, newrelease
-- removed version update of no-longer-existing bldnt.bat. "fixed"
- sed patterns to replace \? with * for the benefit of the deficient
- mac sed.
- newrelease
-
-9.5 changes:
-- updated version to 9.5
- bintar BUILDING NOTICE makefiles/Mf-install.in scheme.1.in
- c/Makefile.i3nt c/Makefile.a6nt c/Makefile.ti3nt c/Makefile.ta6nt
- workarea c/scheme.rc s/7.ss s/cmacros.ss
- release_notes/release_notes.stex csug/csug.stex
-- updated release notes and fixed user's guide overfull hbox.
- release-notes.stex, syntax.stex
-- updated install target to do something more sensible
- release_notes/Makefile
-
-9.5.1 changes:
-- updated version to 9.5.1
- bintar BUILDING NOTICE makefiles/Mf-install.in scheme.1.in
- c/Makefile.i3nt c/Makefile.a6nt c/Makefile.ti3nt c/Makefile.ta6nt
- workarea c/scheme.rc s/7.ss s/cmacros.ss
- release_notes/release_notes.stex csug/csug.stex csug/use.stex
- examples/ez-grammar-test.ss examples/socket.ss
- wininstall/Makefile wininstall/*nt.wxs
-- Added setting of CHEZSCHEMELIBDIRS to s and mats make files so that
- an existing setting will not interfere with the build process, and
- added a note to BUILDING that CHEZSCHEMELIBDIRS should be unset in
- Version 9.5 and before.
- s/Mf-base, mats/Mf-base, BUILDING
-- the $case macro used by r6rs:case and case now unconditionally trims
- redundant keys and expands into exclusive-cond rather than cond.
- it catches references to => before expanding into exclusive-cond
- to avoid supporting => as an undocumented and useless extension
- of the case syntax. the r6rs:case and case macros now require
- multiple clauses rather than leaving the enforcement to exclusive-cond,
- and the exclusive-cond macro now requires multiple clauses rather
- than leaving the enforcement to cond.
- syntax.ss,
- 4.ms, root-experr*, patch*
-- ifdef'd out include of xlocale.h for glibc, since the glibc
- locale.h includes xlocale.h or, in glibc 2.26, its replacement.
- expeditor.c
-- Updated CSUG to replace \INSERTREVISIONMONTHSPACEYEAR with the current
- month and year at the time of generation.
- csug.stex, copyright.stex
-- Updated configuration to set machine types in the CSUG and release notes
- make files, and updated distclean target to remove these files.
- configure, makefiles/Makefile-csug.in (renamed from csug/Makefile),
- makefiles/Makefile-release_notes.in
- (renamed from release_notes/Makefile),
- makefiles/Makefile
-- added pass-time tracking for pre-cpnanopass passes to compile.
- compile.ss
-- added inline handler for fxdiv-and-mod
- cp0.ss, primdata.ss
-- changed order in which return-point operations are done (adjust
- sfp first, then store return values, then restore local saves) to
- avoid storing return values to homes beyond the end of the stack
- in cases where adjusting sfp might result in a call to dooverflood.
- cpnanopass.ss, np-languages.ss
-- removed unused {make-,}asm-return-registers bindings
- cpnanopass.ss
-- corrected the max-fv value field of the lambda produced by the
- hand-coded bytevector=? handler.
- cpnanopass.ss
-- reduced live-pointer and inspector free-variable mask computation
- overhead
- cpnanopass.ss
-- moved regvec cset copies to driver so they aren't copied each
- time a uvar is assigned to a register. removed checks for
- missing register csets, since registers always have csets.
- cpnanopass.ss
-- added closure-rep else clause in record-inspector-information!.
- cpnanopass.ss
-- augmented tree representation with a constant representation
- for full trees to reduce the overhead of manipulating trees or
- subtrees with all bits set.
- cpnanopass.ss
-- tree-for-each now takes start and end offsets; this cuts the
- cost of traversing and applying the action when the range of
- applicable offsets is other than 0..tree-size.
- cpnanopass.ss
-- introduced the notion of poison variables to reduce the cost of
- register/frame allocation for procedures with large sets of local
- variables. When the number of local variables exceeds a given
- limit (currently hardwired to 1000), each variable with a large
- live range is considered poison. A reasonable set of variables
- with large live ranges (the set of poison variables) is computed
- by successive approximation to avoid excessive overhead. Poison
- variables directly conflict with all spillables, and all non-poison
- spillables indirectly conflict with all poison spillables through
- a shared poison-cset. Thus poison variables cannot live in the
- same location as any other variable, i.e., they poison the location.
- Conflicts between frame locations and poison variables are handled
- normally, which allows poison variables to be assigned to
- move-related frame homes. Poison variables are spilled prior to
- register allocation, so conflicts between registers and poison
- variables are not represented. move relations between poison
- variables and frame variables are recorded as usual, but other
- move relations involving poison variables are not recorded.
- cpnanopass.ss, np-languages.ss
-- changed the way a uvar's degree is decremented by remove-victim!.
- instead of checking for a conflict between each pair of victim
- and keeper and decrementing when the conflict is found, remove-victim!
- now decrements the degree of each var in each victim's conflict
- set. while this might decrement other victims' degrees unnecessarily,
- it can be much less expensive when large numbers of variables are
- involved, since the number of conflicts between two non-poison
- variables should be small due to the selection process for
- (non-)poison variables and the fact that the unspillables introduced
- by instruction selection should also have few conflicts. That
- is, it reduces the worst-case complexity of decrementing degrees
- from O(n^2) to O(n).
- cpnanopass.ss
-- took advice in compute-degree! comment to increment the uvars in
- each registers csets rather than looping over the registers for
- each uvar asking whether the register conflicts with the uvar.
- cpnanopass.ss
-- assign-new-frame! now zeros out save-weight for local saves, since
- once they are explicitly saved and restored, they are no longer
- call-live and thus have no save cost.
- cpnanopass.ss
-- desensitized the let-values source-caching timing test slightly
- 8.ms
-- updated allx, bullyx patches
- patch*
-- attempt to stabilize timing tests let-values source-caching
- test and ephemeron gc test while resensitizing the former
- 8.ms, 4.ms
-- various formatting and comment corrections
- workarea,
- s/Mf-base, bytevector.ss, cpnanopass.ss, date.ss,
- 5_6.ms, examples.ms
-- updated newrelease to handle mats/Mf-*nt
- newrelease mats/Mf-a6nt mats/Mf-i3nt mats/Mf-ta6nt mats/Mf-ti3nt
-- fixed gather-filedata's sort of profile entries. for any two
- entries x and y in the list produced by the sort call, if x's
- bfp = y's bfp, x should come before y if x's efp < y's efp.
- The idea is that enclosing entries should always come later
- in the list. this affects only languages where two expressions
- can start at the same character position.
- pdhtml.ss
-- expanded capability of ez-grammar with support for simple
- parsing of binary operators w/precedence and associativity
- and automatically generated markdown grammar descriptions.
- ez-grammar-test.ss now also doubles as a test of pdhtml for
- algebraic languages.
- mats/examples.ms,
- examples/ez-grammar.ss, examples/ez-grammar-test.ss,
- examples/Makefile
-- maybe-compile-{file,program,library} and automatic import
- compilation now treat a malformed object file as if it were
- not present and needs to be regenerated. A malformed object
- file (particularly a truncated one) might occur if the compiling
- processes is killed or aborts before it has a chance to delete
- a partial object file.
- syntax.ss,
- 7.ms
-- fix signature of bytevector-[u/s]16-native-set!
- primdata.ss
-- fix enumerate signature
- primdata.ss
-- added support for Visual Studio 2017.15.5
- wininstall/locate-vcredist.bat
-- fixed substring-fill! and vector-fill! to return void, reflecting the
- documented return value of unspecified value. Also changes substring-fill!
- to use define-who instead of repeating 'substring-fill! in all the error
- messages.
- 5_4.ss, 5_6.ss
-- fix mat of substring-fill!
- after the recent change, the result of substring-fill! is void
- 5_5.ms
-- fix a few signatures
- primdata.ss
-- fix comment about Sscheme_program
- main.c
-- fix even? and odd? to error on exceptional flonums
- 5_3.ss, 5_3.ms, fl.ms, root-experr*, patch*
-- fix bug in date->time-utc caused by incorrect use of difftime in Windows
- stats.c, date.ms, release_notes.stex
-- Check that first argument of map is a procedure in cp02 expansion
- to raise the same error that the non expanded version
- cp0.ss
-- avoid building the result list in a map that is called for effect
- cp0.ss
-- added tests to ensure the optimize-level version 2 of map and for-each raise
- a non-procedure exception when the first argument is not a procedure, even
- when the rest of the program is compiled at optimize level 3.
- 4.ms, root-experr-compile-0-f-f-f, patch-compile-0-t-f-f,
- patch-compile-0-f-t-f, patch-interpret-0-f-t-f, patch-interpret-0-f-f-f,
- patch-interpret-3-f-t-f, patch-interpret-3-f-f-f
-- fix bounds checking with an immediate index on immutable vectors,
- fxvectors, strings, and bytevectors
- cpnanopass.ss, 5_5.ms, 5_6.ms, bytevector.ms
-- fix a few signatures
- primdata.ss
-- more staid and consistent Mf-cross main target
- Mf-cross
-- cpletrec now replaces the incoming prelexes with new ones so
- that it doesn't have to alter the flags on the incoming ones, since
- the same expander output is passed through the compiler twice while
- compiling a file with macro definitions or libraries. we were
- getting away without this just by luck.
- cpletrec.ss
-- pure? and ivory? now return #t for a primref only if the prim is
- declared to be a proc, since some non-proc prims are mutable, e.g.,
- $active-threads and $collect-request-pending.
- cp0.ss
-- $error-handling-mode? and $eol-style? are now properly declared to
- be procs rather than system state variables.
- primdata.ss
-- the new pass $check-prelex-flags verifies that prelex referenced,
- multiply-referenced, and assigned flags are set when they
- should be. (it doesn't, however, complain if a flag is set
- when it need not be.) when the new system parameter
- $enable-check-prelex-flags is set, $check-prelex-flags is
- called after each major pass that produces Lsrc forms to verify
- that the flags are set correctly in the output of the pass.
- this parameter is unset by default but set when running the
- mats.
- cprep.ss, back.ss, compile.ss, primdata.ss,
- mats/Mf-base
-- removed the unnecessary set of prelex referenced flag from the
- build-ref routines when we've just established that it is set.
- syntax.ss, compile.ss
-- equivalent-expansion? now prints differences to the current output
- port to aid in debugging.
- mat.ss
-- the nanopass that patches calls to library globals into calls to
- their local counterparts during whole-program optimization now
- creates new prelexes and sets the prelex referenced, multiply
- referenced, and assigned flags on the new prelexes rather than
- destructively setting flags on the incoming prelexes. The
- only known problems this fixes are (1) the multiply referenced
- flag was not previously being set for cross-library calls when
- it should have been, resulting in overly aggressive inlining
- of library exports during whole-program optimization, and (2)
- the referenced flag could sometimes be set for library exports
- that aren't actually used in the final program, which could
- prevent some unreachable code from being eliminated.
- compile.ss
-- added support for specifying default record-equal and
- record-hash procedures.
- primdata.ss, cmacros.ss, cpnanopass.ss, prims.ss, newhash.ss,
- gc.c,
- record.ms
-- added missing call to relocate for subset-mode tc field, which
- wasn't burning us because the only valid non-false value, the
- symbol system, is in the static generation after the initial heap
- compaction.
- gc.c
-- added a lambda-commonization pass that runs after the other
- source optimizations, particularly inlining, and a new parameter
- that controls how hard it works. the value of commonization-level
- ranges from 0 through 9, with 0 disabling commonization and 9
- maximizing it. The default value is 0 (disabled). At present,
- for non-zero level n, the commonizer attempts to commonize
- lambda expressions consisting of 2^(10-n) or more nodes.
- commonization of one or more lambda expressions requires that
- they have identical structure down to the leaf nodes for quote
- expressions, references to unassigned variables, and primitives.
- So that various downstream optimizations aren't disabled, there
- are some additional restrictions, the most important of which
- being that call-position expressions must be identical. The
- commonizer works by abstracting the code into a helper that
- takes the values of the differing leaf nodes as arguments.
- the name of the helper is formed by concatenating the names of
- the original procedures, separated by '&', and this is the name
- that will show up in a stack trace. The source location will
- be that of one of the original procedures. Profiling inhibits
- commonization, because commonization requires profile source
- locations to be identical.
- cpcommonize.ss (new), compile.ss, interpret.ss, cprep.ss,
- primdata.ss, s/Mf-base,
- mats/Mf-base
-- cpletrec now always produces a letrec rather than a let for
- single immutable lambda bindings, even when not recursive, for
- consistent expand/optimize output whether the commonizer is
- run or not.
- cpletrec.ss,
- record.ms
-- trans-make-ftype-pointer no longer generates a call to
- $verify-ftype-address if the address expression is a call to
- ftype-pointer-address.
- ftype.ss
-- Remove special case for (#2%map p '()) in cp0
- so the reduced version checks that p is a procedure.
- Also make the same change for #2%for-each.
- cp0.ss, 4.ms
-- Mitigate a race condition in Windows when deleting files and directories.
- windows.c
-- add (& ftype) argument/result for foreign-procedure, which supports
- struct arguments and results for foreign calls
- syntax.ss, ftype.ss, cpnanopass.ss, x86.ss, x86_64.ss,
- base-lang.ss, np-languages.ss, cprep.ss, primdata.ss,
- schlib.c, prim.c, externs.h
- mats/foreign4.c, mats/foreign.ms mats/Mf-*
- foreign.stex, release_notes.stex
-- reworked the S_call_help/S_return CCHAIN handling to fix a bug in which
- the signal handler could trip over the NULL jumpbuf in a CCHAIN record.
- schlib.c
-- install equates.h, kernel.o, and main.o on unix-like systems
- Mf-install.in
-- standalone export form now handles (import import-spec ...)
- 8.ms, syntax.ss, release_notes.stex
-- add collect-rendezvous
- prim.c, 7.ss, primdata.ss, 7.ms, smgmt.stex, release_notes.stex
-- added identifier? checks to detect attempts to use non-identifier
- field names in define-record-type field specs.
- syntax.ss,
- record.ms, root-experr*
-- fixed an issue with the library system where an exception that occurs
- during visit or revisit left the library in an inconsistent state that
- caused it to appear that it was still in the process of running. This
- manifested in it raising a cyclic dependency exception, even though
- there really is not a cyclic dependency. The various library
- management functions involved will now reset the part of the library
- when an exception occurs. This also means that if the library visit
- or revisit failed for a transient reason (such as a missing or
- incorrect library version that can be fixed by updating the
- library-directories) it is now possible to recover from these errors.
- expand-lang.ss, syntax.ss, interpret.ss, compile.ss, cprep.ss,
- 8.ms
-- Added -Wno-implicit-fallthrough flag to macOS C makefiles.
- c/Mf-a6osx, c/Mf-i3osx, c/Mf-ta6osx, c/Mf-ti3osx
-- handle compiled library code in boot files once base boot is loaded
- globals.h, scheme.c, 7.ss, 7.ms, primdata.ss
-- add newline to (import-notify) message in compile-whole-library and
- compile-whole-program
- compile.ss
-- add a __collect_safe convention for foreign procedures and callables
- to automate thread [de]activation
- syntax.ss, ftype.ss, x86.ss, x86_64.ss, ppc32.ss,
- cmacros.ss, base-lang.ss, np-languages.ss, cprep.ss, cpcommonize.ss,
- cp0.ss, cpcheck.ss, cpvalid.ss, interpret.ss, cpletrec.ss,
- thread.c, prim.c, externs.h, foreign.stex, release_notes.stex,
- mats/Mf-t*, foreign.ms, foreign4.c
-- Don't install equates.h
- Mf-install.in, wininstall/*nt.wxs
-- Windows install now sets HeapSearchPath in the registry
- wininstall/product.wxs
-- Use Windows path separator character when finding boot files on Windows.
- scheme.c
-- Propagate enable-check-prelex-flags to separate-eval sub-process in tests.
- mats.ss
-- Reject attempts to visit libraries that compile-whole-program has rendered
- invisible due to libs-visible? flag.
- compile.ss, 7.ms, root-experr-compile-0-f-f-f, root-experr-compile-2-f-f-f,
- patch-compile-0-f-t-f, patch-compile-0-t-f-f, patch-interpret-0-f-f-f,
- patch-interpret-0-f-t-f, patch-interpret-3-f-f-f, patch-interpret-3-f-t-f
-- Double FMTBUFSIZE to fix compilation with gcc-8
- c/prim5.c
-- Improved Unicode support for command-line arguments, environment
- variables, the C interface and error messages, and the Windows
- registry, DLL loading, and process creation
- scheme.h, alloc.c, externs.h, fasl.c, foreign.c, io.c, main.c,
- prim5.c, scheme.c, schlib.c, schsig.c, stats.c, system.h,
- version.h, windows.c, foreign.stex, system.stex, mkheader.ss,
- prims.ss
-- Repair x86_64 `&` foreign-procedure result type handling for types of a
- small size that is not a multiple of the word size
- x86_64.ss, foreign.ms, foreign4.c
-- Avoid an occasional invalid memory violation on Windows in S_call_help
- schlib.c
-- Updated csug socket code to match that in examples folder
- csug/foreign.stex, examples/socket.ss
-- add an option --disable-x11
- c/version.h, configure
-- allow s_ee_get_clipboard to use the pastebuffer on macOS even when X11 is not
- available.
- expeditor.c
-- Adjust cp0 to not replace a procedure name from a let wrapper
- cp0.ss, misc.ms
-- allx now runs all up to three (rather than two) times to eliminate
- bootstrap failures after small changes like the recent change to
- procedure names, so we don't have to rebuild the boot files as often.
- Mf-base
-- Fix tests for cp0 procedure-name change
- misc.ms, patch-compile-0-f-t-f, patch-interpret-0-f-t-f
-- add load-compiled-from-port and Sregister_boot_file_fd for loading modes
- based on open files instead of paths
- 7.ss, primdata.ss, mkheader.ss, scheme.c
- 7.ms, foreign.stex, system.stex
-- auto-config improvement, detect if X11 exist on Mac OS X
- configure
-- added box-cas! and vector-cas!
- prims.ss, cpnanopass.ss, np-languages.ss,
- cmacros.ss, library.ss, primdata.ss
- x86_64.ss x86.ss, ppc32.ss, arm32.ss,
- 5_6.ms, 5_8.ms, root-experr*,
- objects.stex, release_notes.stex
-- add generate-procedure-source-information
- cmacros.ss, compile.ss, cpnanopass.ss, inspect.ss,
- primdata.ss, prims.ss, misc.ms,
- system.stex, release_notes.stex
-- fix boot_call and the invoke code object to handle multiple values
- scheme.c, cpnanopass.ss, 7.ms, release_notes.stex, system.stex
-- the compiler now uses a temporary variable to hold the return
- value of a nested call across the restore-local-saves form to
- properly handle the case where the destination lvalue is an mref
- whose base and/or index is a local save.
- cpnanopass.ss,
- misc.ms
-- flush expand-output and expand/optimize-output ports
- compile.ss
-- clarify "unknown module" error message in determine-module-imports
- syntax.ss
-- restore the import code on reset to provide consistent error message
- syntax.ss, 8.ms
-- add uninstall target
- Makefile.in, Makefile-workarea.in, Mf-install.in
-- add PDB files for Windows
- c/*nt, wininstall/*nt.wxs
-- use uuid_generate on unix-like systems for S_unique_id
- BUILDING, c/Mf-*le, stats.c, objects.stex, release_notes.stex
-- when thread_get_room exhausts the local allocation area, it now
- goes through a common path with S_get_more_room to allocate a new
- local allocation area when appropriate. this can greatly reduce
- the use of global allocation (and the number of tc mutex acquires
- in threaded builds) when a lot of small objects are allocated by
- C code with no intervening Scheme-side allocation or dirty writes.
- alloc.c, types.h, externs.h
-- made Windows filename handling in directory-list, file-access-time,
- file-change-time, file-directory?, file-exists?, file-modification-time,
- get-mode, and path-absolute more consistent with
- https://docs.microsoft.com/en-us/windows/desktop/FileIO/naming-a-file
- 6.ss, 6.ms, io.stex, release_notes.stex
-- fix handling of calling code's address for locking around a callable,
- where the cp register copy in the thread context could be changed
- in the callable prep before S_call_help gets it
- cpnanopass.ss, x86_64.ss, x86.ss, foreign2.c, foreign.ms
-- added initialization of seginfo sorted and trigger_ephemerons fields.
- segment.c
-- redirecting output of first two checkboot runs to /dev/null so the
- ignored exception, if any, does not show up in the make output.
- s/Mf-base
-- fixed 7.ms to specify the relative path of testfile.boot
- 7.ms
-- profile counts are now maintained even for code that has been
- reclaimed by the collector and must be released explicitly by the
- programmer via (profile-release-counters).
- pdhtml.ss, primdata.ss,
- globals.h, externs.h, fasl.c, prim5.c, prim.c, alloc.c, scheme.c,
- misc.ms,
- release_notes.stex, system.stex
-- clarified required use of scheme-start to start an application
- packaged as a boot file and added a short "myecho" example.
- use.stex
-- fixed a bug in cp0 bug that could fold the apply of a primitive, where
- the last argument is not a list, as if it were a call to the primitive
- with those arguments
- cp0.ss, cp0.ms
-- fix allocation of string/bytevector for a foreign-callable argument
- or foreign-call return
- cpnanopass.ss, foreign.ms, foreign2.c
-- foreign-callable code objects are now flagged as "templates", and
- the collector now refuses to discard relocation information for
- code objects marked as templates when copying them to the static
- generation.
- cmacros.ss, cpnanopass.ss,
- gc.c,
- 7.ms
-- add hashtable-cells and add a size argument to hashtable-keys,
- hashtable-values, and hashtable-entries
- newhash.ss, primdata.ss,
- hash.ms, root-experr*, patch*,
- objects.stex, release_notes.stex
-- the body of load-library is now wrapped in a $pass-time with
- to show the time spent loading libraries separately from the time
- spent in expand.
- syntax.ss
-- interpret now plays the pass-time game
- interpret.ss
-- added compile-time-value? predicate and
- compile-time-value-value accessor
- syntax.ss, primdata.ss,
- 8.ms, primvars.ms, root-experr*
-- $pass-stats now returns accurate stats for the currently timed
- pass.
- 7.ss
-- compile-whole-program and compile-whole-library now propagate
- recompile info from the named wpo file to the object file
- to support maybe-compile-program and maybe-compile-library in
- the case where compile-whole-{program,library} overwrites the
- original object file.
- compile.ss,
- 7.ms, mat.ss, primvars.ms
-- replaced the ancient and unusable bintar with one that creates
- a useful tarball for binary installs
- bintar
-- generated Mf-install InstallBin (InstallLib, InstallMan) now
- correctly indirects through InstallPrefix if the --installbin
- (--installlib, --installman) configure flag is not present.
- configure
-- removed definition of generate-procedure-source-information
- patch.ss
-- guardian tconc cells are now allocated in generation 0 in the hope
- that they can be released more quickly.
- gc.c
-- added ftype-guardian syntax: (ftype-guardian A) creates a new
- guardian for ftype pointers of type A, the first base field (or
- one of the first base fields in the case of unions) of which must
- be a word-sized integer with native endianness representing a
- reference count. ftype pointers are registered with and retrieved
- from the guardian just like objects are registered with and
- retrieved from any guardian. the difference is that the garbage
- collector decrements the reference count before resurrecting an
- ftype pointer and resurrects only those whose reference counts
- become zero, i.e., are ready for deallocation.
- ftype.ss, cp0.ss, cmacros.ss, cpnanopass.ss, prims.ss, primdata.ss,
- gc.c,
- 4.ms, root-experr*
-- fixed a bug in automatic recompilation handling of missing include
- files specified with absolute pathnames or pathnames starting with
- "./" or "..": was erroring out in file-modification-time with a
- file-not-found or other exception rather than recompiling.
- syntax.ss,
- 7.ms, root-experr*, patch*
-- changed inline vector-for-each and string-for-each code to
- put the last call to the procedure in tail position, as was
- already done for the library definitions and for the inline
- code for for-each.
- cp0.ss,
- 5_4.ms, 5_6.ms
-- the compiler now generates better inline code for the bytevector
- procedure. instead of one byte memory write for each argument,
- it writes up to 4 (32-bit machines) or 8 (64-bit machines) bytes
- at a time, which almost always results in fewer instructions and
- fewer writes.
- cpnanopass.ss,
- bytevector.ms
-- packaged unchanging implicit reader arguments into a single record
- to reduce the number of arguments.
- read.ss
-- recoded run-vector to handle zero-length vectors. it appears
- we're not presently generating empty vectors (representing empty
- groups), but the fasl format permits them.
- 7.ss
-- reverted the earlier change to restore indirection through
- InstallPrefix, since it didn't and can't play well with the
- generated config.h. Instead removed InstallPrefix entirely so
- it isn't an attractive hazard.
- configure, makefiles/Mf-install.in
-- fixed bug in inline-lists: wasn't setting multiply-referenced flag
- on p to account for the procedure? check at optimize-level 2.
- cpletrec.ss
-- fixed bug in check-prelex-flags: was hardwiring $cpcheck-prelex-flags
- "after" argument to 'uncprep rather than passing along its argument.
- compile.ss
-- commented out local definition of sorry! so that problems detected
- by $cpcheck-prelex-flags actually result in a raised exception.
- cprep.ss
-- exposed the default-library-search-handler and a library-search-handler
- parameter to permit more control over the search for libraries during
- import, compile-whole-library, and compile-whole-program
- syntax.ss, primdata.ss,
- 8.ms,
- libraries.stex
-- added fix for whole program/library compilation bug with help from
- @owaddell who originally reported the problem in issue 386. this bug
- arises from the way the parts of the combined library, and their
- binary dependencies, are invoked when one of the constituent libraries
- is invoked. consider, for example, a combined library that contains
- (A) and (B), where (B) depends on a binary library (C). depending on
- the sort order of (A) and (B), which may be unconstrained in the
- partial ordering established by library dependencies, invoking (A) may
- result in the invoke code for (B) being run first, without (B) ever
- being explicitly invoked. this can result in bindings required from
- (C) by the invoke code in (B) to be unbound. even in the case where
- (A) comes before (B) in the topological sort, if they are combined
- into the same cluster, (B)'s invoke code will be run as part of
- invoking (A). the solution is two part: first we extend the invoke
- requirements of the first library in the cluster to include the binary
- libraries that precede it in the topological sort and add a dependency
- on the first library in the cluster to all of the other libraries in
- the cluster. this means no matter which library in the cluster is
- invoked first, it will cause the first library to be invoked, in turn
- ensuring the binary libraries that precede it are invoked. when there
- are multiple clusters, a dependency is added from each cluster to the
- first library in the cluster that precedes it. this ensures that
- invoking a library in a later cluster first, will still cause all of
- the dependencies of the previous clusters to be invoked. ultimately,
- these extra dependencies enforce an ordering on the invocation of the
- source and binary libraries that matches the topological sort, even if
- the topological sort was under constrained. to maintain the property
- that import requirements are a superset of the invoke and visit
- requirements, we also extend the import requirements to include the
- extended invoke requirements. the import requirements are also added
- to the dependency graph to further constrain the topological sort and
- ensure that we do not introduce artificial cycles in the import graph.
- compile.ss,
- 7.ms,
- root-experr*, patch*
-- fixed failure to install examples for tarball installs
- Mf-install.in
-- improved packaging support:
- replaced bintar script with bintar directory and make file;
- tarballs are created via "make create-tarball" and are placed in
- the workarea's bintar directory. added rpm directory and make
- file for creating RPMs via "make create-rpm". added pkg directory
- and make file for creating OSX packages via "make create-pkg".
- bintar (removed), bintar/Makefile (new), rpm/Makefile (new),
- pkg/Makefile (new), pkg/rmpkg (new), workarea, checkin, newrelease,
- Makefile.in, Makefile-workarea.in.
-- improved error message for compile-whole-program and
- compile-whole-library when a top-level expression is discovered while
- processing a wpo file.
- compile.ss
-- minor build and new-release updates
- checkin, newrelease, Makefile.in, Makefile-workarea.in
-- added library-search-handler, compile-whole-library, and improved
- packaging to the release notes.
- release_notes/release_notes.stex
-
-9.5.2 changes:
-- updated version to 9.5.2
- bintar/Makefile rpm/Makefile pkg/Makefile BUILDING NOTICE
- makefiles/Mf-install.in makefiles/Makefile-csug.in scheme.1.in
- c/Makefile.a6nt c/Makefile.i3nt c/Makefile.ta6nt c/Makefile.ti3nt
- mats/Mf-a6nt mats/Mf-i3nt mats/Mf-ta6nt mats/Mf-ti3nt workarea
- c/scheme.rc s/7.ss s/cmacros.ss release_notes/release_notes.stex
- csug/copyright.stex csug/csug.stex rpm/Makefile pkg/Makefile
- wininstall/Makefile wininstall/a6nt.wxs wininstall/i3nt.wxs
- wininstall/ta6nt.wxs wininstall/ti3nt.wxs
-- fixed handling of bintar, rpm, pkg make files
- newrelease
-- fixed a bug in the fasl representation and reading of mutually
- recursive ftypes where one of the members of the cycle is the
- parent of another, which manifested in the fasl reader raising
- bogus "incompatible record type" exceptions. (The bug could also
- affect other record-type descriptors with cycles involving parent
- rtds and "extra" fields.) object files created before this fix
- are incompatible with builds with this fix, and objects files
- created after this fix are incompatible builds without this fix.
- fasl.ss, strip.ss,
- fasl.c,
- ftype.ms,
- release_notes.stex
-
-9.5.3 changes:
-- updated version to 9.5.3
- BUILDING NOTICE makefiles/Mf-install.in makefiles/Makefile-csug.in
- scheme.1.in c/Makefile.a6nt c/Makefile.i3nt c/Makefile.ta6nt
- c/Makefile.ti3nt mats/Mf-a6nt mats/Mf-i3nt mats/Mf-ta6nt
- mats/Mf-ti3nt workarea c/scheme.rc s/7.ss s/cmacros.ss
- release_notes/release_notes.stex csug/copyright.stex csug/csug.stex
- bintar/Makefile rpm/Makefile pkg/Makefile wininstall/Makefile
- wininstall/a6nt.wxs wininstall/i3nt.wxs wininstall/ta6nt.wxs
- wininstall/ti3nt.wxs
-- fixed welcome text and copyright year in macOS package
- newrelease pkg/Makefile release_notes.stex
-- update Windows spin-loop count for deleting files and directories
- windows.c
-- install a file containing revision information alongside boot files;
- embed git revision in exported source archives
- bintar/Makefile Mf-install.in wininstall/*nt.wxs
- s/Mf-base s/.gitattributes s/update-revision
-- ignore multiple-value return from interleaved init expressions in
- top-level-program
- syntax.ss, 8.ms
-- add name fields for mutexes and condition variables, now `make-mutex` and
- `make-condition` accept an optional argument `name`, which must be a
- symbol or #f. The name, if not #f, is printed every time the object is
- printed, which is useful for debugging
- primdata.ss prims.ss print.ss
- thread.ms threads.stex
-- change the default compression mode to LZ4 and add a compress-format
- parameter to select a compression format for output; input infers the
- compression format
- io.ss, bytevector.ss, back.ss, primdata.ss,
- compress.c (new), new-io.c, fasl.c, scheme.c, compress.h (new),
- externs.h, system.h, expeditor.c, configure, Mf-*, Makefile.*nt,
- workarea, mat.ss, io.ms, io.stex, objects.stex, release_notes.stex,
- root-experr*, patch*
-- added compress-level parameter to select a compression level for
- file writing and changed the default for lz4 compression to do a
- better job compressing. finished splitting glz input routines
- apart from glz output routines and did a bit of other restructuring.
- removed gzxfile struct-as-bytevector wrapper and moved its fd
- into glzFile. moved DEACTIVATE to before glzdopen_input calls
- in S_new_open_input_fd and S_compress_input_fd, since glzdopen_input
- reads from the file and could block. the compress format and now
- level are now recorded directly the thread context. replaced
- as-gz? flag bit in compressed bytevector header word with a small
- number of bits recording the compression format at the bottom of
- the header word. flushed a couple of bytevector compression mats
- that depended on the old representation. (these last few changes
- should make adding new compression formats easier.) added
- s-directory build options to choose whether to compress and, if
- so, the format and level.
- compress-io.h, compress-io.c, new-io.c, equates.h, system.h,
- scheme.c, gc.c,
- io.ss, cmacros.ss, back.ss, bytevector.ss, primdata.ss, s/Mf-base,
- io.ms, mat.ss, bytevector.ms, root-experr*,
- release_notes.stex, io.stex, system.stex, objects.stex
-- improved the effectiveness of LZ4 boot-file compression to within
- 15% of gzip by increasing the lz4 output-port in_buffer size to
- 1<<18. With the previous size (1<<14) LZ4-compressed boot files
- were about 50% larger. set the lz4 input-port in_buffer and
- out_buffer sizes to 1<<12 and 1<<14. there's no clear win at
- present for larger input-port buffer sizes.
- compress-io.c
-- To reduce the memory hit for the increased output-port in_buffer
- size and the corresponding increase in computed out_buffer size,
- one output-side out_buffer is now allocated (lazily) per thread
- and stored in the thread context. The other buffers are now
- directly a part of the lz4File_out and lz4File_in structures
- rather than allocated separately.
- compress-io.c, scheme.c, gc.c,
- cmacros.ss
-- split out the buffer emit code from glzwrite_lz4 into a
- separate glzemit_lz4 helper that is now also used by gzclose
- so we can avoid dealing with a NULL buffer in glzwrite_lz4.
- glzwrite_lz4 also uses it to writing large buffers directly and
- avoid the memcpy.
- compress-io.c
-- replaced lz4File_out and lz4File_in mode enumeration with the
- compress format and inputp boolean. using switch to check and
- raising exceptions for unexpected values to further simplify
- adding new compression formats in the future.
- compress-io.c
-- replaced the never-defined struct lz4File pointer in glzFile
- union with the more specific struct lz4File_in_r and Lz4File_out_r
- pointers.
- compress-io.h, compress-io.c
-- added free of lz4 structures to gzclose. also changed file-close
- logic generally so that (1) port is marked closed before anything is
- freed to avoid dangling pointers in the case of an interrupt or
- error, and (2) structures are freed even in the case of a write
- or close error, before the error is reported. also now mallocing
- glz and lz4 structures after possibility of errors have passed where
- possible and freeing them when not.
- compress-io.c,
- io.ss
-- added return-value checks to malloc calls and to a couple of other
- C-library calls.
- compress-io.c
-- corrected EINTR checks to look at errno rather than return codes.
- compress-io.c
-- added S_ prefixes to the glz* exports
- externs.h, compress-io.c, new-io.c, scheme.c, fasl.c
-- added entries for mutex-name and mutex-thread
- threads.stex
-- fix record-ref reduction in cp0
- in expressions like
- (record-ref ... (begin (newline) (record ...)))
- the reduction was dropping the possible side effect expressions
- in this case the (newline).
- cp0.ss
-- zero?, fxzero?, positive?, fxpositive?, etc., now go through
- (a suitably modified) relop-length so that, for example,
- (zero? (length x)) results in the same code as (null? x). added
- correctness tests for these and all of the other predicates that
- go through relop-length.
- cpnanopass.ss, 5_2.ms
-- assertion-violationf and friends now show the who, message, and
- irritants in the original call when who or message is found not to
- be of the right type.
- exceptions.ss
-- fix incorrect uses of fxzero? x86.ss backend, since a 32-bit
- immediate is not necessarily a fixnum
- x86.ss
-- added MinGW/MSYS build support for Windows and configuration for
- Travis-CI testing of all Windows builds
- BUILDING, .travis*, wininstall/Makefile
-- fix multiply of -2^30 with itself on 64-bit platforms
- number.c, 5_3.ms, release_notes.stex
-- fixed typo in description of case macro
- csug/control.stex
-- fix signatures of $annotation-options, $fasl-strip-options,
- $file-options, and $library-requirements-options
- primdata.ss
-- small fix in relop-length to enable the optimization
- cpnanopass.ss
-- make test for relop-length more sensitive
- 5_2.ms
-- added support for Microsoft Visual Studio 2019 on Windows
- BUILDING, c/vs.bat, wininstall/locate-vcredist.bat
-- fixed open-string-input-port on immutable strings
- cpnanopass.ss, io.ms, release_notes.stex
-- use setenv rather than putenv on non WIN32 environments
- prim5.c, system.stex
-- restore {Free,Open,Net}BSD build, support Windows cross-compile
- via MinGW, add configuration options, and add helper makefile targets
- expeditor.c, thread.c, stats.c, statics.c, scheme.c, main.c, types.h,
- externs.h, globals.h, nocurses.h, version.h, system.h, segment.h,
- a6ob.def, ta6ob.def, a6nb.def, ta6nb.def, i3nt.def, ti3nt.def,
- c/Mf-*, build.bat, makefiles/Makefile.in, makefiles/Mf-install.in,
- s/update-revision, BUILDING
-- export `ee-backward-delete-sexp` binding in the expression-editor module.
- expeditor.ss
-- fix ee_read_char to handle ^@ properly
- expeditor.c
-- prevent access before start of array
- scheme.c
-- remove dead stores in files
- compress-io.c, new-io.c
-- fixed tab character in makefiles
- c/Mf-*nt
-- use case-insensitive search for ".exe" on Windows
- c/scheme.c
-- fix __collect_safe for x86_64 and floating-point arguments or results
- x86_64.ss, foreign.ms, release_notes.stex
-- annotations are now preserved in object files for debug
- only, for profiling only, for both, or not at all, depending
- on the settings of generate-inspector-information and
- compile-profile. in particular, when inspector information
- is not enabled but profiling is, source information does
- not leak into error messages and inspector output, though it is
- still available via the profile tools. The mechanics of this
- involved repurposing the fasl a? parameter to hold an annotation
- flags value when it is not #f and remaking annotations with
- new flags if necessary before emitting them.
- compile.ss, fasl.ss, misc.ms
-- altered a number of mats to produce correct results even
- when the 's' directory is profiled.
- misc.ms, cp0.ms, record.ms
-- profile-release-counters is now generation-friendly; that is,
- it doesn't look for dropped code objects in generations that have
- not been collected since the last call to profile-release-counters.
- also, it no longer allocates memory when it releases counters.
- pdhtml.ss,
- gc.c, gcwrapper.c, globals.h, prim5.c
-- removed unused entry points S_ifile, S_ofile, and S_iofile
- alloc.c, externs.h
-- mats that test loading profile info into the compiler's database
- to guide optimization now weed out preexisting entries, in case
- the 's' directory is profiled.
- 4.ms, mat.ss, misc.ms, primvars.ms
-- counters for dropped code objects are now released at the start
- of each mat group.
- mat.ss
-- replaced ehc (enable-heap-check) option with hci (heap-check-interval)
- option that allows heap checks to be performed periodically rather
- than on each collection. hci=0 is equivalent to ehc=f (disabling
- heap checks) and hci=1 is equivalent to ehc=t (enabling heap
- checks every collection), while hci=100 enables heap checks only
- every 100th collection. allx and bullyx mats use this feature
- to reduce heap-checking overhead to a more reasonable level. this
- is particularly important when the 's' directory is profiled,
- since the amount of static memory to be checked is greatly increased
- due to the counters.
- mats/Mf-base, mat.ss, primvars.ms
-- added a mat that calls #%show-allocation, which was otherwise not
- being tested.
- misc.ms
-- removed a broken primvars mat and updated two others. in each case,
- the mat was looking for information about primitives in the wrong
- (i.e., old) place and silently succeeding when it didn't find any
- primitives to test. the revised mats (along with a few others) now
- check to make sure at least one identifier has the information they
- look for. the removed mat was checking for library information that
- is now compiled in, so the mat is now unnecessary. the others were
- (not) doing argument-error checks. fixing these turned up a handful of
- problems that have also been fixed: a couple of unbound variables in the
- mat driver, two broken primdata declarations, a tardy argument check
- by profile-load-data, and a bug in char-ready?, which was requiring
- an argument rather than defaulting it to the current input port.
- primdata.ss, pdhtml.ss, io.ms,
- primdvars.ms, 4.ms, 6.ms, misc.ms, patch*
-- added initial support for recording coverage information. when the
- new parameter generate-covin-files is set, the compiler generates
- .covin files containing the universe of all source objects for which
- profile forms are present in the expander output. when profiling
- and generation of covin files are enabled in the 's' directory, the
- mats optionally generate .covout files for each mat file giving
- the subset of the universe covered by the mat file, along with an
- all.covout in each mat output directory aggregating the coverage
- for the directory and another all.covout in the top-level mat
- directory aggregating the coverage for all directories.
- back.ss, compile.ss, cprep.ss, primdata.ss, s/Mf-base,
- mat.ss, mats/Mf-base, mats/primvars.ms
-- support for generating covout files is now built in. with-coverage-output
- gathers and dumps coverage information, and aggregate-coverage-output
- combines (aggregates) covout files.
- pdhtml.ss, primdata.ss, compile.ss,
- mat.ss, mats/Mf-base, primvars.ms
-- profile-clear now adjusts active coverage trackers to avoid losing
- coverage information.
- pdhtml.ss,
- prim5.c
-- nested with-coverage calls are now supported.
- pdhtml.ss
-- switched to a more compact representation for covin and covout files;
- reduces disk space (compressed or not) by about a factor of four
- and read time by about a factor of two with no increase in write time.
- primdata.ss, pdhtml.ss, cprep.ss, compile.ss,
- mat.ss, mats/Mf-base
-- added support for determining coverage for an entire run, including
- coverage for expressions hit during boot time. 'all' mats now produce
- run.covout files in each output directory, and 'allx' mats produce
- an aggregate run.covout file in the mat directory.
- pdhtml.ss,
- mat.ss, mats/Mf-base
-- profile-release-counters now adjusts active coverage trackers to
- account for the counters that have been released.
- pdhtml.ss,
- prim5.c
-- replaced the artificial "examples" target with a real "build-examples"
- target so make won't think it always has to mats that depend upon
- the examples directory having been compiled. mats make clean now
- runs make clean in the examples directory.
- mats/Mf-base
-- importing a library from an object file now just visits the object
- file rather than doing a full load so that the run-time code for
- the library is not retained. The run-time code is still read
- because the current fasl format forces the entire file to be read,
- but not retaining the code can lower heap size and garbage-collection
- cost, particularly when many object-code libraries are imported.
- The downside is that the file must be revisited if the run-time
- code turns out to be required. This change exposed several
- places where the code was failing to check if a revisit is needed.
- syntax.ss,
- 7.ms, 8.ms, misc.ms, root-experr*
-- fixed typos: was passing unquoted load rather than quoted load
- to $load-library along one path (where it is loading source code
- and therefore irrelevant), and was reporting src-path rather than
- obj-path in a message about failing to define a library.
- syntax.ss
-- compile-file and friends now put all recompile information in
- the first fasl object after the header so the library manager can
- find it without loading the entire fasl file. The library manager
- now does so. It also now checks to see if library object files
- need to be recreated before loading them rather than loading them and
- possibly recompiling them after discovering they are out of date, since
- the latter requires loading the full object file even if it's out of
- date, while the former takes advantage of the ability to extract just
- recompile information. as well as reducing overhead, this eliminates
- possibly undesirable side effects, such as creation and registration
- of out-of-date nongenerative record-type descriptors. because the
- library manager expects to find recompile information at the front of
- an object file, it will not find all recompile information if object
- files are "catted" together. also, compile-file has to hold in memory
- the object code for all expressions in the file so that it can emit the
- unified recompile information, rather than writing to the object file
- incrementally, which can significantly increase the memory required
- to compile a large file full of individual top-level forms. This does
- not affect top-level programs, which were already handled as a whole,
- or a typical library file that contains just a single library form.
- compile.ss, syntax.ss
-- the library manager now checks include files before library dependencies
- when compile-imported-libraries is false (as it already did when
- compile-imported-libraries is true) in case a source change affects
- the set of imported libraries. (A library change can affect the set
- of include files as well, but checking dependencies before include
- files can cause unneeded libraries to be loaded.) The include-file
- check is based on recompile-info rather than dependencies, but the
- library checks are still based on dependencies.
- syntax.ss
-- fixed check for binding of scheme-version. (the check prevents
- premature treatment of recompile-info records as Lexpand forms
- to be passed to $interpret-backend.)
- scheme.c
-- strip-fasl-file now preserves recompile-info when compile-time info
- is stripped.
- strip.ss
-- removed include-req* from library/ct-info and ctdesc records; it
- is no longer needed now that all recompile information is maintained
- separately.
- expand-lang.ss, syntax.ss, compile.ss, cprep.ss, syntax.ss
-- changed the fasl format and reworked a lot of code in the expander,
- compiler, fasl writer, and fasl reader to allow the fasl reader
- to skip past run-time information when it isn't needed and
- compile-time information when it isn't needed. Skipping past
- still involves reading and decoding when encrypted, but the fasl
- reader no longer parses or allocates code and data in the portions
- to be skipped. Side effects of associating record uids with rtds
- are also avoided, as are the side effects of interning symbols
- present only in the skipped data. Skipping past code objects
- also reduces or eliminates the need to synchronize data and
- instruction caches. Since the fasl reader no longer returns
- compile-time (visit) or run-time (revisit) code and data when not
- needed, the fasl reader no longer wraps these objects in a pair
- with a 0 or 1 visit or revisit marker. To support this change,
- the fasl writer generates separate top-level fasl entries (and
- graphs) for separate forms in the same top-level source form
- (e.g., begin or library). This reliably breaks eq-ness of shared
- structure across these forms, which was previously broken only
- when visit or revisit code was loaded at different times (this
- is an incompatible change). Because of the change, fasl "groups"
- are no longer needed, so they are no longer handled.
- 7.ss, cmacros.ss, compile.ss, expand-lang.ss, strip.ss,
- externs.h, fasl.c, scheme.c,
- hash.ms
-- the change above is surfaced in an optional fasl-read "situation"
- argument (visit, revisit, or load). The default is load. visit
- causes it to skip past revisit code and data; revisit causes it
- to skip past visit code and data; and load causes it not to skip
- past either. visit-revisit data produced by (eval-when (visit
- revisit) ---) is never skipped.
- 7.ss, primdata.ss,
- io.stex
-- to improve compile-time and run-time error checking, the
- Lexpand recompile-info, library/rt-info, library-ct-info, and
- program-info forms have been replaced with list-structured forms,
- e.g., (recompile-info ,rcinfo).
- expand-lang.ss, compile.ss, cprep.ss, interpret.ss, syntax.ss
-- added visit-compiled-from-port and revisit-compiled-from-port
- to complement the existing load-compiled-from-port.
- 7.ss, primdata.ss,
- 7.ms,
- system.stex
-- increased amount read when seeking an lz4-compressed input
- file from 32 to 1024 bytes at a time
- compress-io.c
-- replaced the fasl a? parameter value #t with an "all" flag value
- so it's value is consistently a mask.
- cmacros.ss, fasl.ss, compile.ss
-- split off profile mats into a separate file
- misc.ms, profile.ms (new), root-experr*, mats/Mf-base
-- added coverage percent computations to mat allx/bullyx output
- mat.ss, mats/Mf-base, primvars.ms
-- replaced coverage tables with more generic and generally useful
- source tables, which map source objects to arbitrary values.
- pdhtml.ss, compile.ss, cprep.ss, primdata.ss,
- mat.ss, mats/Mf-base, primvars.ms, profile.ms,
- syntax.stex
-- reduced profile counting overhead by using calls to fold-left
- instead of calls to apply and map and by using fixnum operations
- for profile counts on 64-bit machines.
- pdhtml.ss
-- used a critical section to fix a race condition in the calculations
- of profile counts that sometimes resulted in bogus (including
- negative) counts, especially when the 's' directory is profiled.
- pdhtml.ss
-- added discard flag to declaration for hashtable-size
- primdata.ss
-- redesigned the printed representation of source tables and rewrote
- get-source-table! to read and store incrementally to reduce memory
- overhead.
- compile.ss
-- added generate-covin-files to the set of parameters preserved
- by compile-file, etc.
- compile.ss,
- system.stex
-- moved covop argument before the undocumented machine and hostop
- arguments to compile-port and compile-to-port. removed the
- undocumented ofn argument from compile-to-port; using
- (port-name ip) instead.
- compile.ss, primdata.ss,
- 7.ms,
- system.stex
-- compile-port now tries to come up with a file position to supply
- to make-read, which it can do if the port's positions are character
- positions (presently string ports) or if the port is positioned
- at zero.
- compile.ss
-- audited the argument-type-error fuzz mat exceptions and fixed a
- host of problems this turned up (entries follow). added #f as
- an invalid argument for every type for which #f is indeed invalid
- to catch places where the maybe- prefix was missing on the argument
- type. the mat tries hard to determine if the condition raised
- (if any) as the result of an invalid argument is appropriate and
- redirects the remainder to the mat-output (.mo) file prefixed
- with 'Expected error', causing them to show up in the expected
- error output so developers will be encouraged to audit them in
- the future.
- primvars.ms, mat.ss
-- added an initial symbol? test on machine type names so we produce
- an invalid machine type error message rather than something
- confusing like "machine type #f is not supported".
- compile.ss
-- fixed declarations for many primitives that were specified as
- accepting arguments of more general types than they actually
- accept, such as number -> real for various numeric operations,
- symbol -> endianness for various bytevector operations,
- time -> time-utc for time-utc->date, and list -> list-of-string-pairs
- for default-library-search-handler. also replaced some of the
- sub-xxxx types with specific types such as sub-symbol -> endianness
- in utf16->string, but only where they were causing issues with
- the primvars argument-type-error fuzz mat. (this should be done
- more generally.)
- primdata.ss
-- fixed incorrect who arguments (was map instead of fold-right,
- current-date instead of time-utc->date); switched to using
- define-who/set-who! generally.
- 4.ss, date.ss
-- append! now checks all arguments before any mutation
- 5_2.ss
-- with-source-path now properly supplies itself as who for the
- string? argument check; callers like load now do their own checks.
- 7.ss
-- added missing integer? check to $fold-bytevector-native-ref whose
- lack could have resulted in a compile-time error.
- cp0.ss
-- fixed typo in output-port-buffer-mode error message
- io.ss
-- fixed who argument (was fx< rather than fx maybe-timeout)
- primdata.ms
-- added "invalid code page ~s" to set of messages considered valid
- argument-type-check error messages, for Windows multibyte->string
- and string->multibyte.
- primvars.ms
-- used with-object-file to restore accidentally dropped close-port in
- compile-whole-program and compile-whole-library
- compile.ss
-- initialized variable to enable compilation with gcc 9.1.0 at -O3
- c/scheme.c
-- added missing Inner wrappers around the library/ct-info and
- library-rt-info records in the code for compile-whole-xxx.
- compile.ss,
- 7.ms
-- local-eval-hook now calls eval rather than interpret when profiling
- is enabled, so local transformer code can be profiled.
- syntax.ss,
- profile.ms
-- fix compiler bug related to call-with-values and a first argument
- whose body result is compiled to an allocation, inline form, or
- foreign call
- cpnanopass.ss, 3.ms
-- improved error reporting for library compilation-instance errors:
- now including the name of the object file from which the "wrong"
- compilation instance was loaded, if it was loaded from (or compiled
- to) an object file and the original importing library, if it was
- previously loaded from an object file due to a library import.
- syntax.ss, 7.ss, interpret.ss,
- 8.ms, root-experr*
-- removed situation and for-input? arguments from $make-load-binary,
- since the only consumer always passes 'load and #f.
- 7.ss,
- scheme.c
-- $separate-eval now prints the stderr and stdout of the subprocess
- to help in diagnosing separate-eval and separate-compile issues.
- mat.ss
-- added unregister-guardian, which can be used to unregister
- the unresurrected objects registered with any guardian. guardian?
- can be used to distinguish guardian procedures from other objects.
- cp0.ss, cmacros.ss, cpnanopass.ss, ftype.ss, primdata.ss,
- prims.ss,
- gcwrapper.c, prim.c, externs.h,
- 4.ms, primvars.ms
- release_notes.stex
- smgmt.stex, threads.stex
-- added verify-loadability. given a situation (visit, revisit,
- or load) and zero or more pathnames (each of which may be optionally
- paired with a library search path), verity-loadability checks
- whether the set of object files named by those pathnames and any
- additional object files required by library requirements in the
- given situation can be loaded together. it raises an exception
- in each case where actually attempting to load the files would
- raise an exception and additionally in cases where loading files
- would result in the compilation or loading of source files in
- place of the object files. if the check is successful,
- verity-loadability returns an unspecified value. in either case,
- although portions of the object files are read, none of the
- information read from the object files is retained, and none of
- the object code is read, so there are no side effects other than
- the file operations and possibly the raising of an exception.
- library and program info records are now moved to the top of each
- object file produced by one of the file compilation routines,
- just after recompile info, with a marker to allow verity-loadability
- to stop reading once it reads all such records. this change is
- not entirely backward compatible; the repositioning of the records
- can be detected by a call to list-library made from a loaded file
- before the definition of one or more libraries. it is fully
- backward compatible for typical library files that contain a
- single library definition and nothing else. adding this feature
- required changes to the object-file format and corresponding
- changes in the compiler and library manager. it also required
- moving cross-library optimization information from library/ct-info
- records (which verity-loadability must read) to the invoke-code
- for each library (which verity-loadability does not read) to
- avoid reading and permanently associating record-type descriptors
- in the code with their uids.
- compile.ss, syntax.ss, expand-lang.ss, primdata.ss, 7.ss,
- 7.ms, misc.ms, root-experr*, patch*,
- system.stex, release_notes.stex
-- fixed a bug that bit only with the compiler compiled at
- optimize-level 2: add-library/rt-records was building a library/ct-info
- wrapper rather than a library/rt-info wrapper.
- compile.ss
-- fixed a bug in visit-library that could result in an indefinite
- recursion: it was not checking to make sure the call to $visit
- actually added compile-time info to the libdesc record. it's not
- clear, however, whether the libdesc record can be missing
- compile-time information on entry to visit-library, so the code
- that calls $visit (and now checks for compile-time information
- having been added) might not be reachable. ditto for
- revisit-library.
- syntax.ss
- syntax.ss, primdata.ss,
- 7.ms, root-experr*, patch*,
- system.stex, release_notes.stex
-- added some argument-error checks for library-directories and
- library-extensions, and fixed up the error messages a bit.
- syntax.ss,
- 7.ms, root-experr*
-- compile-whole-program now inserts the program record into the
- object file for the benefit of verify-loadability.
- syntax.ss,
- 7.ms, root-experr*
-- changed 'loading' import-notify messages to the more precise
- 'visiting' or 'revisiting' in a couple of places.
- syntax.ss,
- 7.ms, 8.ms
-- added concatenate-object-files
- compile.ss, primdata.ss
- 7.ms, root-experr*
- system.stex, use.stex, release_notes.stex
-- added invoke-library
- syntax.ss, primdata.ss,
- 8.ms, root-experr*,
- libraries.stex, release_notes.stex
-- updated the date
- release_notes.stex
-- libraries contained within a whole program or library are now
- marked pending before their invoke code is run so that invoke
- cycles are reported as such rather than as attempts to invoke
- while still loading.
- compile.ss, syntax.ss, primdata.ss,
- 7.ms, root-experr*
-- the library manager now protects against unbound references
- from separately compiled libraries or programs to identifiers
- ostensibly but not actually exported by (invisible) libraries
- that exist only locally within a whole program. this is done by
- marking the invisibility of the library in the library-info and
- propagating it to libdesc records; the latter is checked upon
- library import, visit, and invoke as well as by verify-loadability.
- the import and visit code of each invisible no longer complains
- about invisibility since it shouldn't be reachable.
- syntax.ss, compile.ss, expand-lang.ss,
- 7.ms, 8.ms, root-experr*, patch*
-- documented that compile-whole-xxx's linearization of the
- library initialization code based on static dependencies might
- not work for dynamic dependencies.
- system.stex
-- optimized bignum right shifts so the code (1) doesn't look at
- shifted-off bigits if the bignum is positive, since it doesn't
- need to know in that case if any bits are set; (2) doesn't look
- at shifted-off bigits if the bignum is negative if it determines
- that at least one bit is set in the bits shifted off the low-order
- partially retained bigit; (3) quits looking, if it must look, for
- one bits as soon as it finds one; (4) looks from both ends under
- the assumption that set bits, if any, are most likely to be found
- toward the high or low end of the bignum rather than just in the
- middle; and (5) doesn't copy the retained bigits and then shift;
- rather shifts as it copies. This leads to dramatic improvements
- when the shift count is large and often significant improvements
- otherwise.
- number.c,
- 5_3.ms,
- release_notes.stex
-- threaded tc argument through to all calls to S_bignum and
- S_trunc_rem so they don't have to call get_thread_context()
- when it might already have been called.
- alloc.c, number.c, fasl.c, print.c, prim5.c, externs.h
-- added an expand-primitive handler to partially inline integer?.
- cpnanopass.ss
-- added some special cases for basic arithmetic operations (+, -, *,
- /, quotient, remainder, and the div/div0/mod/mod0 operations) to
- avoid doing unnecessary work for large bignums when the result
- will be zero (e.g,. multiplying by 0), the same as one of the
- inputs (e.g., adding 0 or multiplying by 1), or the additive
- inverse of one of the inputs (e.g., subtracting from 0, dividing
- by -1). This can have a major beneficial affect when operating
- on large bignums in the cases handled. also converted some uses
- of / into integer/ where going through the former would just add
- overhead without the possibility of optimization.
- 5_3.ss,
- number.c, externs.h, prim5.c,
- 5_3.ms, root-experr, patch*,
- release_notes.stex
-- added a queue to hold pending signals for which handlers have
- been registered via register-signal-handler so up to 63 (configurable
- in the source code) unhandled signals are buffered before the
- handler has to start dropping them.
- cmacros.ss, library.ss, prims.ss, primdata.ss,
- schsig.c, externs.h, prim5.c, thread.c, gc.c,
- unix.ms,
- system.stex, release_notes.stex
-- bytevector-compress now selects the level of compression based
- on the compress-level parameter. Prior to this it always used a
- default setting for compression. the compress-level parameter
- can now take on the new minimum in addition to low, medium, high,
- and maximum. minimum is presently treated the same as low
- except in the case of lz4 bytevector compression, where it
- results in the use of LZ4_compress_default rather than the
- slower but more effective LZ4_compress_HC.
- cmacros,ss, back.ss,
- compress_io.c, new_io.c, externs.h,
- bytevector.ms, mats/Mf-base, root-experr*
- io.stex, objects.stex, release_notes.stex
-- fix fasl-read signature
- primdata.ss
-- console I/O on Windows now supports Unicode characters in the BMP
- expeditor.c, new-io.c, release_notes.stex
-- the collector now releases bignum temporaries in the collector
- rather than relocating them so we don't keep around huge bignum
- temporaries forever.
- gc.c
-- removed the presumably useless vector-handling code from load()
- which used to be required to handle fasl groups.
- scheme.c
-- object files are no longer compressed as a whole, and the parameter
- compile-compressed is no longer defined. instead, the individual
- fasl objects within an object file are compressed whenever the
- new parameter fasl-compressed is set to its default value, #t.
- this allows the fasl reader to seek past portions of an object
- file that are not of interest, i.e., visit-only code and data
- when "revisiting" an object file and revisit-only code and data
- when "visiting" an object file. the compressed portions are
- compressed using the format and level specified by the compress-format
- and compress-level parameters. the C-coded fasl reader and
- boot-file loader no longer handle compressed files; these are
- handled, less efficiently, by the Scheme entry point (fasl-read).
- a warning exception is raised the first time a program attempts
- to create or read a compressed fasl file.
- 7.ss, s/Mf-base, back.ss, bytevector.ss, cmacros.ss, compile.ss,
- fasl-helpers.ss, fasl.ss, primdata.ss, strip.ss, syntax.ss,
- externs.h, fasl.c, gc.c, scheme.c, thread.c,
- mats/6.ms, mats/7.ms, mats/bytevector.ms, mats/misc.ms, patch*,
- root-experr*,
- intro.stex, use.stex, io.stex, system.stex,
- release_notes.stex
-- added begin wrappers around many of the Scheme source files that
- contained multiple expressions to cut down the number of top-level
- fasl objects and increase compressibility. also removed the
- string filenames for debugging at the start of each file that had
- one---these are best inserted universally by a modified compile-file
- during a debugging session when desired. also removed unnecessary
- top-level placeholder definitions for the assignments that follow.
- 4.ss, 5_1.ss, 5_2.ss, 5_3.ss, 5_7.ss, 6.ss, 7.ss, bytevector.ss,
- cafe.ss, cback.ss, compile.ss, cp0.ss, cpcommonize.ss, cpletrec.ss,
- cpnanopass.ss, cprep.ss, cpvalid.ss, date.ss, engine.ss, enum.ss,
- env.ss, event.ss, exceptions.ss, expeditor.ss, fasl.ss, foreign.ss,
- format.ss, front.ss, ftype.ss, inspect.ss, interpret.ss, io.ss,
- library.ss, mathprims.ss, newhash.ss, pdhtml.ss, pretty.ss,
- prims.ss, primvars.ss, print.ss, read.ss, record.ss, reloc.ss,
- strnum.ss, syntax.ss, trace.ss
-- updated bullyx patches
- patch*
-- fixed csug copyright year substitutions and changed revisiondate
- to not be generated, making the csug build reproducible
- newrelease csug/csug.stex
-- fixed Windows build using MSYS2
- c/Mf-a6nt, c/Mf-i3nt, c/Mf-ta6nt, c/Mf-ti3nt, mats/Mf-a6nt,
- mats/Mf-i3nt, mats/Mf-ta6nt, mats/Mf-ti3nt
-- fixed build on Linux with musl libc
- expeditor.c
-- extended primitive folding to primitives that return multiple
- values.
- cp0.ss, primdata.ss,
- cp0.ms
-- fix handling of calling code's address for locking around a callable
- that has a u8*, u16*, or u32* argument, which could cause the
- cp register copy in the thread context to be changed before
- S_call_help gets it
- cpnanopass.ss, schlib.c, foreign2.c, foreign.ms
-- the collector now promotes objects one generation higher at a time
- by default. previously, it promoted every live oldspace object to
- the selected target generation, which could result in objects
- prematurely skipping one or more generations and thus being
- retained longer than their ages justify. the biggest cost in
- terms of code complexity and performance is the recording of
- pointers from older newspace objects to younger newspace objects
- that could not previously occur.
- gc.c, alloc.c, externs.h
-- the collect procedure now takes an additional optional minimum
- target generation argument to allow the new default behavior to
- be overridden.
- 7.ss, primdata.ss,
- gcwrapper.c,
- 7.ms, root-experr*
-- added cn flag to control collect-notify
- mats/Mf-base
-- resweep_weak_pairs now sets sweep_loc to orig_next_loc rather than
- first_loc since the latter could result in unnecessary sweeping of
- existing target-generation weak pairs.
- gc.c
-- added set of S_child_processes[newg] to S_child_processes[oldg]
- in S_do_gc code handling decreases in the maximum generation.
- gcwrapper.c
-- a specialized variant of the collector is used in the common case
- where the max copied generation is 0, the min and max target
- generations are 1, and there are no locked generation 0 objects
- is now used. with the default collection parameters and no locking
- of generation 0 objects, these collections account for 3/4 of all
- collections.
- gc.c, gc-011.c (new), gcwrapper.c, externs.h, c/Mf-base
-- maybe-fire-collector no longer tries to be so precise and instead
- just counts the number of generation-bytes allocated since the
- last gc. surprisingly, rebuilding the s directory requires about
- the same number of collections with this coarser (and less
- expensive) measurement. this change also fixes a problem with
- too-frequent collections when the maximum-generation is set to
- zero. to make the determination even less expensive, a running
- total of bytes in each generation is now maintained in a new
- bytes_of_generation vector, and maybe-fire-collector is no longer
- called when the collector is running.
- alloc.c, gc.c, gcwrapper.c, globals.h
-- copy now copies two pairs at once only if they are in the same
- segment, which saves a few memory references and tests and turns
- out not to reduce the number of opportunities significantly in
- tested programs.
- gc.c
-- occupied_segments, first_loc, base_loc, next_loc, bytes_left,
- bytes_of_space, sweep_loc, and orig_next_loc are now indexed
- by [g][s] rather than [s][g] to improve locality in the default
- (and common) case where there are only a handful of active
- generations.
- globals.h, types.h, segment.c, gc.c, gcwrapper.c, prim5.c
-- documented change to collect procedure
- smgmt.stex, release_notes.stex
-- now maintaining 16-byte architectural stack alignment (if the
- incoming stack is so aligned) on all x86 platforms except
- i3nt/ti3nt. more recent versions of gcc sometimes generate sse
- instructions that require 16-byte stack alignment.
- x86.ss
-- added missing #ifndef WIN32
- gcwrapper.c
-- added initialization of __to_g to make gcc 7.5.0 happy
- gc.c
-- updated Windows makefiles
- c/Makefile.*nt
-- use lowercase for Windows include files
- segment.c, windows.c
-- proper unicode handling when retrieving error messages from the OS
- on Windows
- windows.c
-- repair collector handling of an ephemerons that refers to a
- younger object during incremental promotion
- gc.c, 4.ms
-- added textual-output-port checks for record-writer write argument
- print.ss,
- record.ms, root-experr*
-- now using 64-bit arithmetic for seconds in S_condition_wait to
- prevent a potential 2038 bug, at least on platforms where time_t
- is 64 bits. also now rounding rather than truncating nanoseconds
- in the conversion to milliseconds on Windows.
- thread.c
-- fixed a bug in arm32 that caused an error when generating
- instructions with immediate operands where the immediate was larger
- than 8 bits.
- arm32.ss
-- fixed formatting in arm32.ss
- arm32.ss
-- disabled unsupported mats for arm32le
- foreign.ms, misc.ms
-- fixed callee-save floating point registers for arm32
- arm32.ss, ftype.ss, np-languages.ss, primdata.ss
-- added a mat for the add-with-immediate bug
- misc.ms,
- mats/arm-immediate-1.ss (new), mats/arm-immediate-2.ss (new)
-- added a note about arm32 targets requiring a kernel module for the
- time stamp counter
- prims.ss
-
-9.5.4 changes:
-- updated version to 9.5.4
- BUILDING NOTICE makefiles/Mf-install.in makefiles/Makefile-csug.in
- scheme.1.in c/Makefile.a6nt c/Makefile.i3nt c/Makefile.ta6nt
- c/Makefile.ti3nt mats/Mf-a6nt mats/Mf-i3nt mats/Mf-ta6nt
- mats/Mf-ti3nt workarea c/scheme.rc s/7.ss s/cmacros.ss
- release_notes/release_notes.stex csug/copyright.stex csug/csug.stex
- bintar/Makefile rpm/Makefile pkg/Makefile wininstall/Makefile
- wininstall/a6nt.wxs wininstall/i3nt.wxs wininstall/ta6nt.wxs
- wininstall/ti3nt.wxs
-
-9.5.5 changes:
-- updated version to 9.5.5
- BUILDING NOTICE makefiles/Mf-install.in scheme.1.in c/Makefile.a6nt
- c/Makefile.i3nt c/Makefile.ta6nt c/Makefile.ti3nt mats/Mf-a6nt
- mats/Mf-i3nt mats/Mf-ta6nt mats/Mf-ti3nt workarea c/scheme.rc
- s/cmacros.ss release_notes/release_notes.stex csug/copyright.stex
- csug/csug.stex bintar/Makefile rpm/Makefile pkg/Makefile
- wininstall/Makefile wininstall/a6nt.wxs wininstall/i3nt.wxs
- wininstall/ta6nt.wxs wininstall/ti3nt.wxs
-- newrelease no longer logs as updated files with no actual changes
- newrelease
-- repaired continuation for exception handler of error for returning
- the wrong number of values to a multiple-value context
- cpnanopass.ss, np-languages.ss, 3.ms
-- adjust arm32 backend to not choose shorter instructions for larger
- return-address offsets, which breaks label address assignment
- arm32.ss
-- repair remainder and modulo on flonums by using fmod
- prim5.c, 5_3.ss, 5_3.ms
-- add special case in cpnanopass.ss for (eq? (ftype-pointer-address x) 0)
- cpnanopass.ss
-- fix missing include in externs.h for struct timespec
- c/expeditor.c, c/externs.h, c/prim5.c, c/scheme.c, c/stats.c
-- fix signature of generate-temporaries
- primdata.ss primvars.ss
-- sleep of negative durations now returns immediately
- 7.ss
-- avoid hard-coded paths for utilities in build scripts
- checkin csug/gifs/Makefile csug/math/Makefile examples/Makefile
- makefiles/Makefile-csug.in makefiles/Makefile-release_notes.in
- makefiles/Mf-install.in makefiles/installsh mats/6.ms mats/Mf-a6fb
- mats/Mf-a6le mats/Mf-a6nb mats/Mf-a6ob mats/Mf-a6osx mats/Mf-arm32le
- mats/Mf-i3fb mats/Mf-i3le mats/Mf-i3nb mats/Mf-i3ob mats/Mf-i3osx
- mats/Mf-i3qnx mats/Mf-ppc32le mats/Mf-ta6fb mats/Mf-ta6le mats/Mf-ta6nb
- mats/Mf-ta6ob mats/Mf-ta6osx mats/Mf-ti3fb mats/Mf-ti3le mats/Mf-ti3nb
- mats/Mf-ti3ob mats/Mf-ti3osx mats/Mf-tppc32le mats/unix.ms newrelease
- pkg/Makefile release_notes/gifs/Makefile release_notes/math/Makefile
- s/Mf-base workarea
-- fixed configure script for update of nanopass to v1.9.2
- configure
-- fixed help description for configure options --installschemename,
- --installpetitename, and --installscriptname
- configure
-- maybe-compile-program now returns void
- compile.ss 7.ms
-- fixed right shift of a negative bignum by a multiple of 32
- number.c 5_3.ms
-- fixed the documentation of load-shared-object to mention an up-to-date
- dll for Windows
- foreign.stex
-- New spellings #true and #false for #t and #f are recognized
- read.ss 6.ms
-- refactor mats to allow different configurations to run in parallel.
- The {partial,all,bully}x targets in Mats/Mf-base now support running
- in parallel if make chooses to do so (e.g., if instructed via -j).
- Update travis-ci build scripts to use new partialx target and run
- jobs in parallel (based on the number of cores available). Also
- add the ability to "skip" (i.e., error before building) travis targets
- by using a line (or lines) beginning with "travis:only:" and listing
- the desired target machine type(s) in the commit message.
- .travis.yml .travis/{build,test,maybe-skip-build}.sh
- mats/{5_4,6,7,8,bytevector,examples,foreign}.ms
- mats/{ftype,hash,io,misc,primvars,profile,record}.ms
- mats/Mf-base mats/Mf-*nt mats/mat.ss mats/patch-interpret*
-- fix x86_64 (& integer-8) and (& integer-16) foreign-call argument
- passing
- x86_64, s/Mf-[t]a6{le,osx}
-- fixed misnamed pattern variables in bytevector-*-ref
- bytevector.ss
-- add workaround for Rosetta 2 bug in [t]a6osx builds. The overhead
- during native (x86) execution is the addition of a single int compare
- and branch in S_bytevector_read, plus a small amount of work at startup
- to determine whether we are running under Rosetta translation.
- new-io.c, scheme.c, version.h
-- use a 7-byte NOP in the x86_64 fasl relocator instead of 7 1-byte NOPs
- fasl.c
-- Move unused terminals in L4.5 to later languages.
- np-languages.ss
-- vector literals can be made self-evaluating with the new parameter
- self-evaluating-vectors
- s/back.ss s/primdata.ss s/syntax.ss csug/objects.tex mats/misc.ms
-- remove obsolete travis-ci.org configuration
- README.md .travis.yml .travis/*
-- add GitHub actions workflow for automated testing
- .github/workflows/{build.sh,summary,test.sh,test.yml}
-- corrected signature of compile-whole-program and compile-whole-library
- s/primdata.ss
-- clarify rd-bytevector error message for non-atomic token types, such
- as vparen, where the token value is #f
- mats/6.ms, mats/root-experr-compile-0-f-f-f,
- mats/root-experr-compile-2-f-f-f, release_notes/release_notes.stex,
- s/read.ss
-- include an identifier name in the syntax error for missing ellipsis
- mats/8.ms, mats/root-experr-compile-0-f-f-f,
- mats/root-experr-compile-2-f-f-f, release_notes/release_notes.stex,
- s/syntax.ss
-
-9.5.6 changes:
-- added back.patch to patchobj
- s/Mf-base
-- updated version to 9.5.6
- makefiles/Mf-install.in scheme.1.in c/Makefile.a6nt c/Makefile.i3nt
- c/Makefile.ta6nt c/Makefile.ti3nt mats/Mf-a6nt mats/Mf-i3nt
- mats/Mf-ta6nt mats/Mf-ti3nt workarea c/scheme.rc s/7.ss
- s/cmacros.ss release_notes/release_notes.stex csug/copyright.stex
- csug/csug.stex rpm/Makefile pkg/Makefile wininstall/Makefile
- wininstall/a6nt.wxs wininstall/i3nt.wxs wininstall/ta6nt.wxs
- wininstall/ti3nt.wxs
-
-9.5.7 changes:
-- updated version to 9.5.7
- BUILDING NOTICE makefiles/Mf-install.in scheme.1.in c/Makefile.a6nt
- c/Makefile.i3nt c/Makefile.ta6nt c/Makefile.ti3nt mats/Mf-a6nt
- mats/Mf-i3nt mats/Mf-ta6nt mats/Mf-ti3nt workarea c/scheme.rc
- s/cmacros.ss release_notes/release_notes.stex csug/copyright.stex
- csug/csug.stex bintar/Makefile rpm/Makefile pkg/Makefile
- wininstall/Makefile wininstall/a6nt.wxs wininstall/i3nt.wxs
- wininstall/ta6nt.wxs wininstall/ti3nt.wxs
-- fix bug in printf with certain control strings and argument counts
- s/format.ss mats/format.ms mats/root-experr-compile-{0,2}-fff
- release_notes/release_notes.stex
-- updated ftypes to allow native ftypes to be used even if another
- non-ftype syntactic binding for the type exists. for instance, if a
- syntactic binding for integer-32 is introduced which is not bound to
- an ftd, using integer-32 in the context of an ftype will still work.
- this change also allows an ftype binding to be created for a native
- type by using (define-ftype ), allowing
- users to create standard ftype bindings for the native-types if that
- is preferred.
- s/ftype.ss, mats/ftype.ms
-- fix occasional 0xC0000409 STATUS_STACK_BUFFER_OVERRUN crash on 64-bit
- Windows from Microsoft's longjmp by implementing our own setjmp/longjmp
- c/Makefile.{a6nt,ta6nt} c/Mf-{a6nt,ta6nt} c/a6nt-jump.asm c/externs.h
- c/types.h c/version.h release_notes/release_notes.stex
-- support Microsoft Visual Studio 2022 on Windows
- BUILDING, c/vs.bat, wininstall/locate-vcredist.bat
-- make threaded foreign mats more robust
- mats/foreign.ms
-- fix rational-valued? for numbers with an exceptional real part
- s/5_3.ss mats/5_1.ms
-- change behavior of mixed exact/inexact arithmetic comparisons in
- the range where fixnums have greater precision than flonums. This
- makes <=, =, and >= transitive as required by R6RS. (< and > were
- already transitive, but the behavior is changed to match.)
- s/5_3.ss mats/5_3.ms
-- consolidate the $thread-check code in misc.ms and thread.ms, keeping
- the thread.ms version of the code since it is more recent
- mats/misc.ms mats/thread-check.ss mats/thread.ms
-- Replace K&R style function declarations with ANSI style
- c/alloc.c c/arm32le.c c/externs.h c/fasl.c c/flushcache.c c/foreign.c
- c/gc.c c/gcwrapper.c c/i32le.c c/intern.c c/io.c c/itest.c c/new-io.c
- c/number.c c/ppc32.c c/ppc32le.c c/prim.c c/prim5.c c/print.c c/scheme.c
- c/schlib.c c/schsig.c c/segment.c c/statics.c c/stats.c c/symbol.c
- c/thread.c c/windows.c mats/foreign1.c
-- Eliminate PROTO macro from scheme.h
- boot/*/scheme.h c/Makefile.* c/alloc.c c/externs.h c/fasl.c c/flushcache.c
- c/foreign.c c/gc.c c/gcwrapper.c c/intern.c c/io.c c/new-io.c c/number.c
- c/prim.c c/prim5.c c/print.c c/scheme.c c/schlib.c c/schsig.c c/segment.c
- c/thread.c mats/foreign3.c s/mkheader.ss
-- update lz4 to version 1.9.3
- configure
-- update zlib to version 1.2.12 (which fixes CVE-2018-25032)
- configure c/Mf-*le
-
-9.5.8 changes:
-- updated version to 9.5.8
- BUILDING NOTICE makefiles/Mf-install.in scheme.1.in c/Makefile.a6nt
- c/Makefile.i3nt c/Makefile.ta6nt c/Makefile.ti3nt mats/Mf-a6nt
- mats/Mf-i3nt mats/Mf-ta6nt mats/Mf-ti3nt workarea c/scheme.rc s/7.ss
- s/cmacros.ss release_notes/release_notes.stex csug/copyright.stex
- csug/csug.stex bintar/Makefile rpm/Makefile pkg/Makefile
- wininstall/Makefile wininstall/a6nt.wxs wininstall/i3nt.wxs
- wininstall/ta6nt.wxs wininstall/ti3nt.wxs newrelease
-
-9.5.9 changes:
-- updated version to 9.5.9
- BUILDING NOTICE makefiles/Mf-install.in scheme.1.in c/Makefile.a6nt
- c/Makefile.i3nt c/Makefile.ta6nt c/Makefile.ti3nt mats/Mf-a6nt
- mats/Mf-i3nt mats/Mf-ta6nt mats/Mf-ti3nt workarea c/scheme.rc
- s/cmacros.ss release_notes/release_notes.stex csug/copyright.stex
- csug/csug.stex bintar/Makefile rpm/Makefile pkg/Makefile
- wininstall/Makefile wininstall/a6nt.wxs wininstall/i3nt.wxs
- wininstall/ta6nt.wxs wininstall/ti3nt.wxs
-- fix arm32le compilation systems using musl libc
- c/arm32le.c
-- added install-docs target for make and corresponding configuration
- options: --installdoc, --installcsug, and --installreleasenotes
- configure makefiles/Makefile.in
-- fixed a bug in `char-` that led to returning a large positive integer
- result when the second argument had a value greater than the first.
- It now returns a negative number in this situation.
- cpnanopass.ss
- 5_4.ms root-experr-* patch-*
-- fix ppc32 conditional-branch code generation when displacement is
- exactly 32764
- s/ppc32.ss
-- fix callable floating-point argument allocation on x86
- s/cpnanopass.ss
-- corrected signature of multibyte->string and string->multibyte
- s/primdata.ss
-- fix typos found by Eric Lindblad
- c/alloc.c c/compress-io.c c/gc.c c/gcwrapper.c c/new-io.c c/prim5.c
- c/schsig.c csug/csug.stex csug/syntax.stex examples/template.ss
- mats/4.ms mats/6.ms mats/7.ms mats/8.ms mats/bytevector.ms mats/foreign.ms
- mats/io.ms mats/mat.ss mats/misc.ms mats/oop.ms mats/oop.ss mats/profile.ms
- mats/record.ms mats/unix.ms s/5_3.ss s/7.ss s/arm32.ss s/base-lang.ss
- s/cmacros.ss s/cp0.ss s/cpnanopass.ss s/date.ss s/format.ss s/io.ss
- s/mkheader.ss s/np-languages.ss s/pdhtml.ss s/ppc32.ss s/print.ss
- s/syntax.ss s/x86.ss s/x86_64.ss
-- Unicode 14.0 support
- unicode/* s/5_4.ss mats/5_4.ms mats/6.ms
-- don't rely on signed integer overflow (UB) in symhash implementation
- c/foreign.c
-- Propagate immutable versions of "", #(), #vu8() and #vfx() in cp0.
- s/cp0.ss s/cpnanopass.ss
-- correct mislabeling of some functions as macros and vice versa in
- docs + correct name of Slocked_objectp from Sunlocked_objectp
- csug/foreign.stex
diff --git a/ta6ob/Makefile b/ta6ob/Makefile
deleted file mode 100644
index e330fd7..0000000
--- a/ta6ob/Makefile
+++ /dev/null
@@ -1,70 +0,0 @@
-# Makefile-workarea.in
-# Copyright 1984-2017 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.
-
-MAKEFLAGS += --no-print-directory
-PREFIX=
-
-.PHONY: build
-build:
- (cd c && $(MAKE))
- (cd s && $(MAKE) bootstrap)
-
-.PHONY: install
-install: build
- $(MAKE) -f Mf-install
-
-.PHONY: uninstall
-uninstall:
- $(MAKE) -f Mf-install uninstall
-
-.PHONY: test
-test: build
- (cd mats && $(MAKE) allx)
- @echo "test run complete. check $(PREFIX)mats/summary for errors."
-
-.PHONY: coverage
-coverage:
- rm -f s/bootstrap
- (cd c && $(MAKE))
- (cd s && $(MAKE) bootstrap p=t c=t)
- (cd mats && $(MAKE) allx c=t)
-
-.PHONY: bootfiles
-bootfiles: build
- $(MAKE) -f Mf-boot
-
-.PHONY: bintar
-bintar: build
- (cd bintar && $(MAKE))
-
-.PHONY: rpm
-rpm: bintar
- (cd rpm && $(MAKE))
-
-.PHONY: pkg
-pkg: bintar
- (cd pkg && $(MAKE))
-
-.PHONY: clean
-clean:
- rm -f petite.1 scheme.1
- (cd s && $(MAKE) clean)
- (cd c && $(MAKE) clean)
- (cd mats && $(MAKE) clean)
- (cd examples && $(MAKE) clean)
- (cd bintar && $(MAKE) clean)
- (cd rpm && $(MAKE) clean)
- (cd pkg && $(MAKE) clean)
- rm -f Make.out
diff --git a/ta6ob/Mf-boot b/ta6ob/Mf-boot
deleted file mode 100644
index 3d657cd..0000000
--- a/ta6ob/Mf-boot
+++ /dev/null
@@ -1,28 +0,0 @@
-# Mf-boot.in
-# Copyright 1984-2017 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.
-
-bootfiles=$(addsuffix .boot, $(shell cd ../boot ; echo *))
-
-doit: $(bootfiles)
-
-%.boot:
- ( cd .. ; ./workarea $* xc-$* )
- ( cd ../xc-$*/s ; make -f Mf-cross base=../../ta6ob --jobs=2 m=ta6ob xm=$* )
- for x in `echo scheme.boot petite.boot scheme.h equates.h` ; do\
- if [ ! -h ../xc-$*/boot/$*/$$x ] ; then \
- mv -f ../xc-$*/boot/$*/$$x ../boot/$*/$$x ;\
- fi ;\
- done
- rm -rf ../xc-$*
diff --git a/ta6ob/Mf-install b/ta6ob/Mf-install
deleted file mode 100644
index 578da08..0000000
--- a/ta6ob/Mf-install
+++ /dev/null
@@ -1,164 +0,0 @@
-# Mf-install.in
-# Copyright 1984-2017 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.
-
-###############################################################################
-# the following variables are set up by configure #
-###############################################################################
-
-m=ta6ob
-
-# The following variables determine where the executables, boot files,
-# example programs, and manual pages are installed.
-
-# executable directory
-InstallBin=/usr/local/bin
-
-# library directory
-InstallLib=/usr/local/lib
-
-# man page directory
-InstallMan=/usr/local/man/man1
-
-# installation owner
-InstallOwner=
-
-# installation group
-InstallGroup=
-
-# Files are actually installed at ${TempRoot}${InstallBin},
-# ${TempRoot}${InstallLib}, and ${TempRoot}${InstallMan}.
-# This useful for testing the install process and for building
-# installation scripts
-TempRoot=
-
-# compress man pages?
-GzipManPages=yes
-
-# executable names
-InstallSchemeName=scheme
-InstallPetiteName=petite
-InstallScriptName=scheme-script
-
-# Whether to install "kernel.o" or "libkernel.a"
-InstallKernelTarget=installkernelobj
-
-# Maybe install libz.a and liblz4.a by setting to "installzlib" and "installliz4"
-InstallZlibTarget=
-InstallLZ4Target=
-
-###############################################################################
-# no changes should be needed below this point #
-###############################################################################
-
-Version=csv9.5.9
-Include=boot/$m
-PetiteBoot=boot/$m/petite.boot
-SchemeBoot=boot/$m/scheme.boot
-Revision=boot/$m/revision
-Scheme=bin/$m/scheme
-Petite=bin/$m/petite
-InstallLibExamples=${InstallLib}/${Version}/examples
-InstallLibBin=${InstallLib}/${Version}/$m
-
-Bin=${TempRoot}${InstallBin}
-Lib=${TempRoot}${InstallLib}/${Version}
-LibExamples=${TempRoot}${InstallLibExamples}
-LibBin=${TempRoot}${InstallLibBin}
-Man=${TempRoot}${InstallMan}
-PetitePath=${Bin}/${InstallPetiteName}
-SchemePath=${Bin}/${InstallSchemeName}
-SchemeScriptPath=${Bin}/${InstallScriptName}
-
-install: bininstall libbininstall maninstall liblibinstall ${InstallKernelTarget}
-
-uninstall:
- rm -rf ${Lib}
- rm -f ${PetitePath}
- rm -f ${SchemePath}
- rm -f ${SchemeScriptPath}
- rm -f ${Man}/${InstallPetiteName}.1{,.gz}
- rm -f ${Man}/${InstallSchemeName}.1{,.gz}
-
-scheme.1 petite.1: scheme.1.in
- sed -e "s;{InstallBin};${InstallBin};g" \
- -e "s;{InstallLibExamples};${InstallLibExamples};g" \
- -e "s;{InstallLibBin};${InstallLibBin};g" \
- -e "s;{InstallPetiteName};${InstallPetiteName};g" \
- -e "s;{InstallSchemeName};${InstallSchemeName};g" \
- -e "s;{InstallScriptName};${InstallScriptName};g" \
- scheme.1.in > $@
-
-###############################################################################
-# no useful external targets below this line #
-###############################################################################
-
-I=./installsh -o "${InstallOwner}" -g "${InstallGroup}"
-
-bininstall: ${Bin}
- $I -m 555 ${Scheme} ${SchemePath}
- ln -f ${SchemePath} ${PetitePath}
- ln -f ${SchemePath} ${SchemeScriptPath}
-
-libbininstall: ${LibBin}
- $I -m 444 ${PetiteBoot} ${LibBin}/petite.boot
- if [ "${InstallPetiteName}" != "petite" ]; then\
- rm -f ${LibBin}/${InstallPetiteName}.boot;\
- ln -f ${LibBin}/petite.boot ${LibBin}/${InstallPetiteName}.boot;\
- fi
- $I -m 444 ${SchemeBoot} ${LibBin}/scheme.boot;\
- if [ "${InstallSchemeName}" != "scheme" ]; then\
- rm -f ${LibBin}/${InstallSchemeName}.boot;\
- ln -f ${LibBin}/scheme.boot ${LibBin}/${InstallSchemeName}.boot;\
- fi
- ln -f ${LibBin}/scheme.boot ${LibBin}/${InstallScriptName}.boot;
- $I -m 444 ${Include}/main.o ${LibBin}
- $I -m 444 ${Include}/scheme.h ${LibBin}
- $I -m 444 ${Revision} ${LibBin}/revision
-
-installkernelobj: ${LibBin}
- $I -m 444 ${Include}/kernel.o ${LibBin}
-
-installkernellib: ${LibBin} ${InstallZlibTarget} ${InstallLZ4Target}
- $I -m 444 ${Include}/libkernel.a ${LibBin}
-
-installzlib: ${LibBin}
- $I -m 444 zlib/libz.a ${LibBin}
-
-installlz4: ${LibBin}
- $I -m 444 lz4/lib/liblz4.a ${LibBin}
-
-maninstall: scheme.1 petite.1 ${Man}
- $I -m 444 scheme.1 ${Man}/${InstallSchemeName}.1
- if [ ${GzipManPages} = yes ] ; then gzip -f ${Man}/${InstallSchemeName}.1 ; fi
- $I -m 444 petite.1 ${Man}/${InstallPetiteName}.1
- if [ ${GzipManPages} = yes ] ; then gzip -f ${Man}/${InstallPetiteName}.1 ; fi
-
-liblibinstall: ${LibExamples}
- $I -m 444 examples/* ${LibExamples}
-
-${Lib}:
- $I -d -m 755 ${Lib}
-
-${LibBin}: ${Lib}
- $I -d -m 755 ${LibBin}
-
-${LibExamples}: ${Lib}
- $I -d -m 755 ${LibExamples}
-
-${Bin}:
- $I -d -m 755 ${Bin}
-
-${Man}:
- $I -d -m 755 ${Man}
diff --git a/ta6ob/bin/petite b/ta6ob/bin/petite
deleted file mode 100755
index 44364cd..0000000
Binary files a/ta6ob/bin/petite and /dev/null differ
diff --git a/ta6ob/bin/scheme b/ta6ob/bin/scheme
deleted file mode 100755
index 44364cd..0000000
Binary files a/ta6ob/bin/scheme and /dev/null differ
diff --git a/ta6ob/bin/ta6ob/petite b/ta6ob/bin/ta6ob/petite
deleted file mode 100755
index 44364cd..0000000
Binary files a/ta6ob/bin/ta6ob/petite and /dev/null differ
diff --git a/ta6ob/bin/ta6ob/scheme b/ta6ob/bin/ta6ob/scheme
deleted file mode 100755
index 44364cd..0000000
Binary files a/ta6ob/bin/ta6ob/scheme and /dev/null differ
diff --git a/ta6ob/bintar/Makefile b/ta6ob/bintar/Makefile
deleted file mode 100644
index a928206..0000000
--- a/ta6ob/bintar/Makefile
+++ /dev/null
@@ -1,86 +0,0 @@
-# Makefile
-# Copyright 1984-2017 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.
-
-version = 9.5.9
-m := $(shell find ../bin/* -type d | xargs basename)
-
-R = csv$(version)
-TARBALL = $(R)-$(m).tar.gz
-
-CONTENTS=\
- $(R)/LICENSE\
- $(R)/NOTICE\
- $(R)/scheme.1.in\
- $(R)/installsh\
- $(R)/Makefile\
- $(R)/examples\
- $(R)/boot\
- $(R)/bin
-
-$(TARBALL): $(CONTENTS)
- ( BROKEN=`find -L $R -type l` ; \
- if test -n "$$BROKEN" ; then \
- echo "Error: missing $(BROKEN)" ; \
- exit 1 ; \
- fi )
- tar -czhf $(TARBALL) $R
- rm -rf $(R)
-
-$(R)/LICENSE: $(R)
- ( cd $(R) ; ln -s ../../../LICENSE . )
-
-$(R)/NOTICE: $(R)
- ( cd $(R) ; ln -s ../../../NOTICE . )
-
-$(R)/scheme.1.in: $(R)
- ( cd $(R) ; ln -s ../../scheme.1.in . )
-
-$(R)/installsh: $(R)
- ( cd $(R) ; ln -s ../../installsh . )
-
-$(R)/Makefile: $(R)
- ( cd $(R) ; ln -s ../../Mf-install Makefile )
-
-$(R)/examples: $(R)
- ( cd $(R) ; ln -s ../../examples . )
-
-$(R)/boot: $(R)
- mkdir -p $(R)/boot/$(m)
- ( cd $(R)/boot/$(m) ; ln -s ../../../../boot/$(m)/{scheme.h,petite.boot,scheme.boot,revision} . )
- case $(m) in \
- *nt) \
- ( cd $R/boot/$(m) ; ln -s ../../../../boot/$(m)/{csv959md.lib,csv959mt.lib,mainmd.obj,mainmt.obj,scheme.res} . ) \
- ;; \
- *) \
- ( cd $R/boot/$(m) ; ln -s ../../../../boot/$(m)/{main.o,kernel.o} . ) \
- ;; \
- esac
-
-$(R)/bin: $(R)
- mkdir -p $(R)/bin/$(m)
- case $(m) in \
- *nt) \
- ( cd $R/bin/$(m) ; ln -s ../../../../bin/$(m)/{scheme.exe,csv959.dll,csv959.lib,vcruntime140.lib} . ) \
- ;; \
- *) \
- ( cd $R/bin/$(m) ; ln -s ../../../../bin/$(m)/scheme . ) \
- ;; \
- esac
-
-$(R):
- mkdir $(R)
-
-clean:
- rm -rf $(R) $(TARBALL)
diff --git a/ta6ob/boot/ta6ob/equates.h b/ta6ob/boot/ta6ob/equates.h
deleted file mode 100644
index ba38a96..0000000
--- a/ta6ob/boot/ta6ob/equates.h
+++ /dev/null
@@ -1,993 +0,0 @@
-/* equates.h for Chez Scheme Version 9.5.9 */
-
-/* Do not edit this file. It is automatically generated and */
-/* specifically tailored to the version of Chez Scheme named */
-/* above. Always be certain that you have the correct version */
-/* of this file for the version of Chez Scheme you are using. */
-
-/* Warning: Some macros may evaluate arguments more than once. */
-
-/* Integer typedefs */
-typedef char I8;
-typedef unsigned char U8;
-typedef short I16;
-typedef unsigned short U16;
-typedef int I32;
-typedef unsigned int U32;
-typedef long I64;
-typedef unsigned long U64;
-
-/* constants from cmacros.ss */
-#define $c_func_closure_index 0x4
-#define $c_func_closure_record_index 0x3
-#define $c_func_code_object_index 0x2
-#define $c_func_code_record_index 0x1
-#define COMPRESS_FORMAT_BITS 0x3
-#define COMPRESS_GZIP 0x0
-#define COMPRESS_HIGH 0x3
-#define COMPRESS_LOW 0x1
-#define COMPRESS_LZ4 0x1
-#define COMPRESS_MAX 0x4
-#define COMPRESS_MEDIUM 0x2
-#define COMPRESS_MIN 0x0
-#define ERROR_CALL_ARGUMENT_COUNT 0x4
-#define ERROR_CALL_NONPROCEDURE 0x3
-#define ERROR_CALL_NONPROCEDURE_SYMBOL 0x2
-#define ERROR_CALL_UNBOUND 0x1
-#define ERROR_MVLET 0x8
-#define ERROR_NONCONTINUABLE_INTERRUPT 0x6
-#define ERROR_OTHER 0x0
-#define ERROR_RESET 0x5
-#define ERROR_VALUES 0x7
-#define OPEN_ERROR_EXISTS 0x2
-#define OPEN_ERROR_EXISTSNOT 0x3
-#define OPEN_ERROR_OTHER 0x0
-#define OPEN_ERROR_PROTECTION 0x1
-#define PORT_FLAG_BINARY 0x400
-#define PORT_FLAG_BLOCK_BUFFERED 0x20000
-#define PORT_FLAG_BOL 0x8000
-#define PORT_FLAG_CHAR_POSITIONS 0x100000
-#define PORT_FLAG_CLOSED 0x800
-#define PORT_FLAG_COMPRESSED 0x2000
-#define PORT_FLAG_EOF 0x10000
-#define PORT_FLAG_EXCLUSIVE 0x4000
-#define PORT_FLAG_FILE 0x1000
-#define PORT_FLAG_FOLD_CASE 0x400000
-#define PORT_FLAG_INPUT 0x100
-#define PORT_FLAG_INPUT_MODE 0x80000
-#define PORT_FLAG_LINE_BUFFERED 0x40000
-#define PORT_FLAG_NO_FOLD_CASE 0x800000
-#define PORT_FLAG_OUTPUT 0x200
-#define PORT_FLAG_R6RS 0x200000
-#define SAPPEND 0x3
-#define SDEFAULT 0x4
-#define SEOF -0x1
-#define SERROR 0x0
-#define SICONV_DUNNO 0x0
-#define SICONV_INCOMPLETE 0x2
-#define SICONV_INVALID 0x1
-#define SICONV_NOROOM 0x3
-#define SREPLACE 0x2
-#define STRVNCATE 0x1
-#define address_bits 0x40
-#define alloc_waste_maximum 0x800
-#define annotation_all 0x3
-#define annotation_debug 0x1
-#define annotation_profile 0x2
-#define architecture x86_64
-#define asm_arg_reg_cnt 0x3
-#define asm_arg_reg_max 0x5
-#define bigit_bits 0x20
-#define bigit_bytes 0x4
-#define bignum_data_disp 0x9
-#define bignum_length_factor 0x40
-#define bignum_length_offset 0x6
-#define bignum_sign_offset 0x5
-#define bignum_type_disp 0x1
-#define black_hole (ptr)0x46
-#define box_ref_disp 0x9
-#define box_type_disp 0x1
-#define byte_alignment 0x10
-#define byte_constant_mask 0xFFFFFFFFFFFFFFFF
-#define bytes_per_card 0x200
-#define bytes_per_segment 0x4000
-#define bytevector_data_disp 0x9
-#define bytevector_immutable_flag 0x4
-#define bytevector_length_factor 0x8
-#define bytevector_length_offset 0x3
-#define bytevector_type_disp 0x1
-#define c_entry_name_vector #(thread-context get-thread-context handle-apply-overflood handle-docall-error handle-overflow handle-overflood handle-nonprocedure-symbol thread-list split-and-resize raw-collect-cond raw-tc-mutex activate-thread deactivate-thread unactivate-thread handle-values-error handle-mvlet-error handle-arg-error foreign-entry install-library-entry get-more-room scan-remembered-set instantiate-code-object Sreturn Scall-one-result Scall-any-results)
-#define c_entry_vector_size 0x19
-#define cached_stack_link_disp 0x8
-#define cached_stack_size_disp 0x0
-#define card_offset_bits 0x9
-#define cards_per_segment 0x20
-#define char_data_offset 0x8
-#define char_factor 0x100
-#define closure_code_disp 0x3
-#define closure_data_disp 0xB
-#define code_arity_mask_disp 0x21
-#define code_closure_length_disp 0x29
-#define code_data_disp 0x41
-#define code_flag_continuation 0x2
-#define code_flag_guardian 0x8
-#define code_flag_system 0x1
-#define code_flag_template 0x4
-#define code_flags_offset 0x8
-#define code_info_disp 0x31
-#define code_length_disp 0x9
-#define code_name_disp 0x19
-#define code_pinfos_disp 0x39
-#define code_reloc_disp 0x11
-#define code_type_disp 0x1
-#define collect_interrupt_index 0x1
-#define continuation_code_disp 0x3
-#define continuation_link_disp 0x23
-#define continuation_return_address_disp 0x2B
-#define continuation_stack_clength_disp 0x1B
-#define continuation_stack_disp 0xB
-#define continuation_stack_length_disp 0x13
-#define continuation_winders_disp 0x33
-#define countof_bignum 0x5
-#define countof_box 0x9
-#define countof_bytevector 0x15
-#define countof_closure 0x3
-#define countof_code 0xB
-#define countof_continuation 0x4
-#define countof_ephemeron 0x19
-#define countof_exactnum 0x8
-#define countof_flonum 0x2
-#define countof_fxvector 0x14
-#define countof_guardian 0x17
-#define countof_inexactnum 0x7
-#define countof_locked 0x16
-#define countof_oblist 0x18
-#define countof_pair 0x0
-#define countof_port 0xA
-#define countof_ratnum 0x6
-#define countof_relocation_table 0x10
-#define countof_rtd_counts 0xE
-#define countof_stack 0xF
-#define countof_string 0x13
-#define countof_symbol 0x1
-#define countof_thread 0xC
-#define countof_tlc 0xD
-#define countof_types 0x1A
-#define countof_vector 0x12
-#define countof_weakpair 0x11
-#define default_collect_trip_bytes 0x800000
-#define default_heap_reserve_ratio 1.0
-#define default_max_nonstatic_generation 0x4
-#define default_stack_size 0xFFF0
-#define default_timer_ticks 0x3E8
-#define dtvec_hour 0x3
-#define dtvec_isdst 0x9
-#define dtvec_mday 0x4
-#define dtvec_min 0x2
-#define dtvec_mon 0x5
-#define dtvec_nsec 0x0
-#define dtvec_sec 0x1
-#define dtvec_size 0xC
-#define dtvec_tzname 0xB
-#define dtvec_tzoff 0xA
-#define dtvec_wday 0x7
-#define dtvec_yday 0x8
-#define dtvec_year 0x6
-#define ephemeron_car_disp 0x7
-#define ephemeron_cdr_disp 0xF
-#define ephemeron_next_disp 0x17
-#define ephemeron_trigger_next_disp 0x1F
-#define eq_hashtable_subtype_ephemeron 0x2
-#define eq_hashtable_subtype_normal 0x0
-#define eq_hashtable_subtype_weak 0x1
-#define exactnum_imag_disp 0x11
-#define exactnum_real_disp 0x9
-#define exactnum_type_disp 0x1
-#define fasl_fld_double 0xA
-#define fasl_fld_i16 0x2
-#define fasl_fld_i24 0x3
-#define fasl_fld_i32 0x4
-#define fasl_fld_i40 0x5
-#define fasl_fld_i48 0x6
-#define fasl_fld_i56 0x7
-#define fasl_fld_i64 0x8
-#define fasl_fld_ptr 0x0
-#define fasl_fld_single 0x9
-#define fasl_fld_u8 0x1
-#define fasl_header #vu8(0 0 0 0 99 104 101 122)
-#define fasl_type_base_rtd 0x1A
-#define fasl_type_box 0x1
-#define fasl_type_bytevector 0x1D
-#define fasl_type_closure 0x6
-#define fasl_type_code 0xB
-#define fasl_type_entry 0xD
-#define fasl_type_ephemeron 0x1C
-#define fasl_type_eq_hashtable 0x1F
-#define fasl_type_exactnum 0x14
-#define fasl_type_flonum 0x8
-#define fasl_type_fxvector 0x1B
-#define fasl_type_gensym 0x13
-#define fasl_type_graph 0x10
-#define fasl_type_graph_def 0x11
-#define fasl_type_graph_ref 0x12
-#define fasl_type_gzip 0x2B
-#define fasl_type_header 0x0
-#define fasl_type_immediate 0xC
-#define fasl_type_immutable_box 0x29
-#define fasl_type_immutable_bytevector 0x28
-#define fasl_type_immutable_fxvector 0x27
-#define fasl_type_immutable_string 0x26
-#define fasl_type_immutable_vector 0x25
-#define fasl_type_inexactnum 0x5
-#define fasl_type_large_integer 0xA
-#define fasl_type_library 0xE
-#define fasl_type_library_code 0xF
-#define fasl_type_lz4 0x2C
-#define fasl_type_pair 0x7
-#define fasl_type_ratnum 0x3
-#define fasl_type_record 0x17
-#define fasl_type_revisit 0x23
-#define fasl_type_rtd 0x18
-#define fasl_type_small_integer 0x19
-#define fasl_type_string 0x9
-#define fasl_type_symbol 0x2
-#define fasl_type_symbol_hashtable 0x20
-#define fasl_type_uncompressed 0x2A
-#define fasl_type_vector 0x4
-#define fasl_type_visit 0x22
-#define fasl_type_visit_revisit 0x24
-#define fasl_type_weak_pair 0x1E
-#define fixnum_bits 0x3D
-#define fixnum_factor 0x8
-#define fixnum_offset 0x3
-#define fld_byte_index 0x4
-#define fld_mutablep_index 0x2
-#define fld_name_index 0x1
-#define fld_type_index 0x3
-#define flonum_data_disp 0x6
-#define forward_address_disp 0x8
-#define forward_marker (ptr)0x2E
-#define forward_marker_disp 0x0
-#define ftype_guardian_rep (ptr)0x56
-#define fxvector_data_disp 0x9
-#define fxvector_immutable_flag 0x8
-#define fxvector_length_factor 0x10
-#define fxvector_length_offset 0x4
-#define fxvector_type_disp 0x1
-#define guardian_entry_next_disp 0x18
-#define guardian_entry_obj_disp 0x0
-#define guardian_entry_rep_disp 0x8
-#define guardian_entry_tconc_disp 0x10
-#define hashtable_default_size 0x8
-#define header_size_bignum 0x8
-#define header_size_bytevector 0x8
-#define header_size_closure 0x8
-#define header_size_code 0x40
-#define header_size_fxvector 0x8
-#define header_size_record 0x8
-#define header_size_reloc_table 0x10
-#define header_size_string 0x8
-#define header_size_vector 0x8
-#define ignore_event_flag 0x0
-#define inexactnum_imag_disp 0x19
-#define inexactnum_pad_disp 0x9
-#define inexactnum_real_disp 0x11
-#define inexactnum_type_disp 0x1
-#define int_bits 0x20
-#define integer_divide_instruction 1
-#define keyboard_interrupt_index 0x3
-#define library_entry_vector_size 0x210
-#define libspec_closure_index 0xD
-#define libspec_does_not_expect_headroom_index 0x0
-#define libspec_error_index 0xE
-#define libspec_fake_index 0x10
-#define libspec_flags_index 0x2
-#define libspec_has_does_not_expect_headroom_version_index 0xF
-#define libspec_index_base_offset 0x1
-#define libspec_index_base_size 0x9
-#define libspec_index_offset 0x0
-#define libspec_index_size 0xA
-#define libspec_interface_offset 0xA
-#define libspec_interface_size 0x3
-#define libspec_name_index 0x1
-#define log2_ptr_bytes 0x3
-#define long_bits 0x40
-#define long_long_bits 0x40
-#define machine_type 0x10
-#define machine_type_a6fb 0x15
-#define machine_type_a6le 0xB
-#define machine_type_a6nb 0x19
-#define machine_type_a6nt 0x1B
-#define machine_type_a6ob 0xF
-#define machine_type_a6osx 0xD
-#define machine_type_a6s2 0x11
-#define machine_type_alist ((0 . any) (1 . i3le) (2 . ti3le) (3 . i3nt) (4 . ti3nt) (5 . i3fb) (6 . ti3fb) (7 . i3ob) (8 . ti3ob) (9 . i3osx) (10 . ti3osx) (11 . a6le) (12 . ta6le) (13 . a6osx) (14 . ta6osx) (15 . a6ob) (16 . ta6ob) (17 . a6s2) (18 . ta6s2) (19 . i3s2) (20 . ti3s2) (21 . a6fb) (22 . ta6fb) (23 . i3nb) (24 . ti3nb) (25 . a6nb) (26 . ta6nb) (27 . a6nt) (28 . ta6nt) (29 . i3qnx) (30 . ti3qnx) (31 . arm32le) (32 . tarm32le) (33 . ppc32le) (34 . tppc32le))
-#define machine_type_any 0x0
-#define machine_type_arm32le 0x1F
-#define machine_type_i3fb 0x5
-#define machine_type_i3le 0x1
-#define machine_type_i3nb 0x17
-#define machine_type_i3nt 0x3
-#define machine_type_i3ob 0x7
-#define machine_type_i3osx 0x9
-#define machine_type_i3qnx 0x1D
-#define machine_type_i3s2 0x13
-#define machine_type_limit 0x23
-#define machine_type_name ta6ob
-#define machine_type_ppc32le 0x21
-#define machine_type_ta6fb 0x16
-#define machine_type_ta6le 0xC
-#define machine_type_ta6nb 0x1A
-#define machine_type_ta6nt 0x1C
-#define machine_type_ta6ob 0x10
-#define machine_type_ta6osx 0xE
-#define machine_type_ta6s2 0x12
-#define machine_type_tarm32le 0x20
-#define machine_type_ti3fb 0x6
-#define machine_type_ti3le 0x2
-#define machine_type_ti3nb 0x18
-#define machine_type_ti3nt 0x4
-#define machine_type_ti3ob 0x8
-#define machine_type_ti3osx 0xA
-#define machine_type_ti3qnx 0x1E
-#define machine_type_ti3s2 0x14
-#define machine_type_tppc32le 0x22
-#define mask_bignum 0x1F
-#define mask_bignum_sign 0x20
-#define mask_binary_input_port 0x5FF
-#define mask_binary_output_port 0x6FF
-#define mask_binary_port 0x4FF
-#define mask_boolean 0xF7
-#define mask_box 0x7F
-#define mask_bwp 0xFFFFFFFFFFFFFFFF
-#define mask_bytevector 0x3
-#define mask_char 0xFF
-#define mask_closure 0x7
-#define mask_code 0xFF
-#define mask_continuation_code 0x2FF
-#define mask_eof 0xFFFFFFFFFFFFFFFF
-#define mask_exactnum 0xFFFFFFFFFFFFFFFF
-#define mask_false 0xFFFFFFFFFFFFFFFF
-#define mask_fixnum 0x7
-#define mask_flonum 0x7
-#define mask_fxvector 0x7
-#define mask_guardian_code 0x8FF
-#define mask_immediate 0x7
-#define mask_inexactnum 0xFFFFFFFFFFFFFFFF
-#define mask_input_port 0x1FF
-#define mask_mutable_box 0xFFFFFFFFFFFFFFFF
-#define mask_mutable_bytevector 0x7
-#define mask_mutable_fxvector 0xF
-#define mask_mutable_string 0xF
-#define mask_mutable_vector 0xF
-#define mask_nil 0xFFFFFFFFFFFFFFFF
-#define mask_octet -0x7F9
-#define mask_other_number 0xF
-#define mask_output_port 0x2FF
-#define mask_pair 0x7
-#define mask_port 0xFF
-#define mask_ratnum 0xFFFFFFFFFFFFFFFF
-#define mask_record 0x7
-#define mask_rtd_counts 0xFFFFFFFFFFFFFFFF
-#define mask_signed_bignum 0x3F
-#define mask_string 0x7
-#define mask_symbol 0x7
-#define mask_system_code 0x1FF
-#define mask_textual_input_port 0x5FF
-#define mask_textual_output_port 0x6FF
-#define mask_textual_port 0x4FF
-#define mask_thread 0xFFFFFFFFFFFFFFFF
-#define mask_tlc 0xFFFFFFFFFFFFFFFF
-#define mask_typed_object 0x7
-#define mask_unbound 0xFFFFFFFFFFFFFFFF
-#define mask_vector 0x7
-#define max_float_alignment 0x8
-#define max_integer_alignment 0x8
-#define max_real_space 0xB
-#define max_space 0xC
-#define max_sweep_space 0xA
-#define maximum_bignum_length (iptr)0x3FFFFFFFFFFFFFF
-#define maximum_bytevector_length (iptr)0xFFFFFFFFFFFFFFF
-#define maximum_fxvector_length (iptr)0xFFFFFFFFFFFFFFF
-#define maximum_interrupt_index 0x4
-#define maximum_string_length (iptr)0xFFFFFFFFFFFFFFF
-#define maximum_vector_length (iptr)0xFFFFFFFFFFFFFFF
-#define minimum_segment_request 0x80
-#define most_negative_fixnum (iptr)-0x1000000000000000
-#define most_positive_fixnum (iptr)0xFFFFFFFFFFFFFFF
-#define native_endianness little
-#define one_shot_headroom 0xC00
-#define ordinary_type_bits 0x8
-#define pair_car_disp 0x7
-#define pair_cdr_disp 0xF
-#define pair_shift 0x4
-#define port_flag_binary 0x4
-#define port_flag_block_buffered 0x200
-#define port_flag_bol 0x80
-#define port_flag_char_positions 0x1000
-#define port_flag_closed 0x8
-#define port_flag_compressed 0x20
-#define port_flag_eof 0x100
-#define port_flag_exclusive 0x40
-#define port_flag_file 0x10
-#define port_flag_fold_case 0x4000
-#define port_flag_input 0x1
-#define port_flag_input_mode 0x800
-#define port_flag_line_buffered 0x400
-#define port_flag_no_fold_case 0x8000
-#define port_flag_output 0x2
-#define port_flag_r6rs 0x2000
-#define port_flags_offset 0x8
-#define port_handler_disp 0x9
-#define port_ibuffer_disp 0x39
-#define port_icount_disp 0x19
-#define port_ilast_disp 0x31
-#define port_info_disp 0x41
-#define port_name_disp 0x49
-#define port_obuffer_disp 0x29
-#define port_ocount_disp 0x11
-#define port_olast_disp 0x21
-#define port_type_disp 0x1
-#define prelex_is_flags_offset 0x8
-#define prelex_is_mask 0xFF00
-#define prelex_sticky_mask 0xFF
-#define prelex_was_flags_offset 0x10
-#define primary_type_bits 0x3
-#define ptr_bits 0x40
-#define ptr_bytes 0x8
-#define ptrdiff_t_bits 0x40
-#define ratnum_denominator_disp 0x11
-#define ratnum_numerator_disp 0x9
-#define ratnum_type_disp 0x1
-#define real_space_alist ((new . 0) (impure . 1) (symbol . 2) (port . 3) (weakpair . 4) (ephemeron . 5) (pure . 6) (continuation . 7) (code . 8) (pure-typed-object . 9) (impure-record . 10) (data . 11))
-#define record_data_disp 0x9
-#define record_type_counts_disp 0x49
-#define record_type_disp 0x1
-#define record_type_flags_disp 0x39
-#define record_type_flds_disp 0x31
-#define record_type_mpm_disp 0x21
-#define record_type_name_disp 0x29
-#define record_type_parent_disp 0x9
-#define record_type_pm_disp 0x19
-#define record_type_size_disp 0x11
-#define record_type_type_disp 0x1
-#define record_type_uid_disp 0x41
-#define reloc_abs 0x0
-#define reloc_code_offset_index 0x3
-#define reloc_code_offset_mask 0x3FFFFFF
-#define reloc_code_offset_offset 0x4
-#define reloc_extended_format 0x1
-#define reloc_item_offset_index 0x2
-#define reloc_item_offset_mask 0x3FFFFFF
-#define reloc_item_offset_offset 0x1E
-#define reloc_longp_index 0x4
-#define reloc_table_code_disp 0x8
-#define reloc_table_data_disp 0x10
-#define reloc_table_size_disp 0x0
-#define reloc_type_index 0x1
-#define reloc_type_mask 0x7
-#define reloc_type_offset 0x1
-#define reloc_x86_64_call 0x1
-#define reloc_x86_64_jump 0x2
-#define return_address_frame_size_disp -0x10
-#define return_address_livemask_disp -0x20
-#define return_address_mv_return_address_disp -0x8
-#define return_address_toplink_disp -0x18
-#define rp_header_frame_size_disp 0x10
-#define rp_header_livemask_disp 0x0
-#define rp_header_mv_return_address_disp 0x18
-#define rp_header_toplink_disp 0x8
-#define rtd_counts_data_disp 0x11
-#define rtd_counts_timestamp_disp 0x9
-#define rtd_counts_type_disp 0x1
-#define rtd_generative 0x1
-#define rtd_opaque 0x2
-#define rtd_sealed 0x4
-#define sbwp (ptr)0x4E
-#define scaled_shot_1_shot_flag -0x8
-#define scheme_version 0x90509
-#define segment_card_offset_bits 0x5
-#define segment_offset_bits 0xE
-#define segment_t1_bits 0x10
-#define segment_t2_bits 0x11
-#define segment_t3_bits 0x11
-#define segment_table_levels 0x3
-#define seof (ptr)0x36
-#define sfalse (ptr)0x6
-#define short_bits 0x10
-#define signal_interrupt_index 0x4
-#define size_box 0x10
-#define size_cached_stack 0x10
-#define size_continuation 0x40
-#define size_ephemeron 0x20
-#define size_exactnum 0x20
-#define size_flonum 0x10
-#define size_forward 0x10
-#define size_guardian_entry 0x20
-#define size_inexactnum 0x20
-#define size_pair 0x10
-#define size_port 0x50
-#define size_ratnum 0x20
-#define size_record_type 0x50
-#define size_rp_header 0x20
-#define size_rtd_counts 0x810
-#define size_symbol 0x30
-#define size_tc 0x2C0
-#define size_thread 0x10
-#define size_tlc 0x20
-#define size_typed_object 0x10
-#define size_t_bits 0x40
-#define snil (ptr)0x26
-#define space_char_list (#\n #\i #\x #\q #\w #\e #\p #\k #\c #\r #\s #\d #\e)
-#define space_cname_list ("new" "impure" "symbol" "port" "weakpr" "emph" "pure" "cont" "code" "p-tobj" "ip-rec" "data" "empty")
-#define space_code 0x8
-#define space_continuation 0x7
-#define space_data 0xB
-#define space_empty 0xC
-#define space_ephemeron 0x5
-#define space_impure 0x1
-#define space_impure_record 0xA
-#define space_locked 0x20
-#define space_new 0x0
-#define space_old 0x40
-#define space_port 0x3
-#define space_pure 0x6
-#define space_pure_typed_object 0x9
-#define space_symbol 0x2
-#define space_weakpair 0x4
-#define stack_frame_limit 0x200
-#define stack_slop 0x400
-#define static_generation 0xFF
-#define string_char_bits 0x20
-#define string_char_bytes 0x4
-#define string_char_offset 0x2
-#define string_data_disp 0x9
-#define string_immutable_flag 0x8
-#define string_length_factor 0x10
-#define string_length_offset 0x4
-#define string_type_disp 0x1
-#define strue (ptr)0xE
-#define sunbound (ptr)0x1E
-#define svoid (ptr)0x3E
-#define symbol_hash_disp 0x2D
-#define symbol_name_disp 0x1D
-#define symbol_plist_disp 0x15
-#define symbol_pvalue_disp 0xD
-#define symbol_splist_disp 0x25
-#define symbol_value_disp 0x5
-#define tc_DSTBV_disp 0x2A8
-#define tc_SRCBV_disp 0x2B0
-#define tc_U_disp 0x160
-#define tc_V_disp 0x168
-#define tc_W_disp 0x170
-#define tc_X_disp 0x178
-#define tc_Y_disp 0x180
-#define tc_ac0_disp 0x28
-#define tc_ac1_disp 0x30
-#define tc_active_disp 0x134
-#define tc_alloc_counter_disp 0x298
-#define tc_ap_disp 0x50
-#define tc_arg_regs_disp 0x0
-#define tc_block_counter_disp 0x1D8
-#define tc_cchain_disp 0x120
-#define tc_code_ranges_to_flush_disp 0x128
-#define tc_compile_profile_disp 0x230
-#define tc_compress_format_disp 0x278
-#define tc_compress_level_disp 0x280
-#define tc_cp_disp 0x40
-#define tc_current_error_disp 0x1D0
-#define tc_current_input_disp 0x1C0
-#define tc_current_mso_disp 0x1E8
-#define tc_current_output_disp 0x1C8
-#define tc_default_record_equal_procedure_disp 0x268
-#define tc_default_record_hash_procedure_disp 0x270
-#define tc_disable_count_disp 0x198
-#define tc_eap_disp 0x58
-#define tc_esp_disp 0x48
-#define tc_fxfirst_bit_set_bv_disp 0x200
-#define tc_fxlength_bv_disp 0x1F8
-#define tc_generate_inspector_information_disp 0x238
-#define tc_generate_procedure_source_information_disp 0x240
-#define tc_generate_profile_forms_disp 0x248
-#define tc_guardian_entries_disp 0x118
-#define tc_instr_counter_disp 0x290
-#define tc_keyboard_interrupt_pending_disp 0x1B0
-#define tc_lz4_out_buffer_disp 0x288
-#define tc_meta_level_disp 0x228
-#define tc_null_immutable_bytevector_disp 0x218
-#define tc_null_immutable_fxvector_disp 0x210
-#define tc_null_immutable_string_disp 0x220
-#define tc_null_immutable_vector_disp 0x208
-#define tc_optimize_level_disp 0x250
-#define tc_parameters_disp 0x2A0
-#define tc_random_seed_disp 0x130
-#define tc_real_eap_disp 0x90
-#define tc_ret_disp 0x60
-#define tc_scheme_stack_disp 0x138
-#define tc_scheme_stack_size_disp 0x150
-#define tc_sfd_disp 0x1E0
-#define tc_sfp_disp 0x38
-#define tc_signal_interrupt_pending_disp 0x1A0
-#define tc_signal_interrupt_queue_disp 0x1A8
-#define tc_something_pending_disp 0x188
-#define tc_stack_cache_disp 0x140
-#define tc_stack_link_disp 0x148
-#define tc_subset_mode_disp 0x258
-#define tc_suppress_primitive_inlining_disp 0x260
-#define tc_target_machine_disp 0x1F0
-#define tc_td_disp 0x88
-#define tc_threadno_disp 0x1B8
-#define tc_timer_ticks_disp 0x190
-#define tc_trap_disp 0x68
-#define tc_ts_disp 0x80
-#define tc_virtual_registers_disp 0x98
-#define tc_winders_disp 0x158
-#define tc_xp_disp 0x70
-#define tc_yp_disp 0x78
-#define thread_tc_disp 0x9
-#define thread_type_disp 0x1
-#define time_collector_cpu 0x5
-#define time_collector_real 0x6
-#define time_duration 0x2
-#define time_monotonic 0x3
-#define time_process 0x0
-#define time_t_bits 0x40
-#define time_thread 0x1
-#define time_utc 0x4
-#define timer_interrupt_index 0x2
-#define tlc_ht_disp 0x11
-#define tlc_keyval_disp 0x9
-#define tlc_next_disp 0x19
-#define tlc_type_disp 0x1
-#define type_bignum 0x6
-#define type_binary_input_port 0x51E
-#define type_binary_output_port 0x61E
-#define type_binary_port 0x41E
-#define type_boolean 0x6
-#define type_box 0xE
-#define type_bytevector 0x1
-#define type_char 0x16
-#define type_closure 0x5
-#define type_code 0x3E
-#define type_continuation_code 0x23E
-#define type_exactnum 0x56
-#define type_fixnum 0x0
-#define type_flonum 0x2
-#define type_fxvector 0x3
-#define type_guardian_code 0x83E
-#define type_immediate 0x6
-#define type_immutable_box 0x8E
-#define type_immutable_bytevector 0x5
-#define type_immutable_fxvector 0xB
-#define type_immutable_string 0xA
-#define type_immutable_vector 0x8
-#define type_inexactnum 0x36
-#define type_input_port 0x11E
-#define type_io_port 0x31E
-#define type_mutable_box 0xE
-#define type_mutable_bytevector 0x1
-#define type_mutable_fxvector 0x3
-#define type_mutable_string 0x2
-#define type_mutable_vector 0x0
-#define type_negative_bignum 0x26
-#define type_octet 0x0
-#define type_other_number 0x6
-#define type_output_port 0x21E
-#define type_pair 0x1
-#define type_port 0x1E
-#define type_positive_bignum 0x6
-#define type_ratnum 0x16
-#define type_record 0x7
-#define type_rtd_counts 0x6E
-#define type_string 0x2
-#define type_symbol 0x3
-#define type_system_code 0x13E
-#define type_textual_input_port 0x11E
-#define type_textual_output_port 0x21E
-#define type_textual_port 0x1E
-#define type_thread 0x4E
-#define type_tlc 0x5E
-#define type_typed_object 0x7
-#define type_vector 0x0
-#define typed_object_type_disp 0x1
-#define typedef_i16 "short"
-#define typedef_i32 "int"
-#define typedef_i64 "long"
-#define typedef_i8 "char"
-#define typedef_iptr "long int"
-#define typedef_ptr "void *"
-#define typedef_string_char "unsigned int"
-#define typedef_u16 "unsigned short"
-#define typedef_u32 "unsigned int"
-#define typedef_u64 "unsigned long"
-#define typedef_u8 "unsigned char"
-#define typedef_uptr "unsigned long int"
-#define typemod 0x8
-#define unactivate_mode_deactivate 0x1
-#define unactivate_mode_destroy 0x2
-#define unactivate_mode_noop 0x0
-#define unaligned_floats 1
-#define unaligned_integers 1
-#define underflow_limit 0x80
-#define unscaled_shot_1_shot_flag -0x1
-#define vector_data_disp 0x9
-#define vector_immutable_flag 0x8
-#define vector_length_factor 0x10
-#define vector_length_offset 0x4
-#define vector_type_disp 0x1
-#define virtual_register_count 0x10
-#define wchar_bits 0x20
-
-/* constants from declare-c-entries */
-#define CENTRY_Scall_any_results 24
-#define CENTRY_Scall_one_result 23
-#define CENTRY_Sreturn 22
-#define CENTRY_activate_thread 11
-#define CENTRY_deactivate_thread 12
-#define CENTRY_foreign_entry 17
-#define CENTRY_get_more_room 19
-#define CENTRY_get_thread_context 1
-#define CENTRY_handle_apply_overflood 2
-#define CENTRY_handle_arg_error 16
-#define CENTRY_handle_docall_error 3
-#define CENTRY_handle_mvlet_error 15
-#define CENTRY_handle_nonprocedure_symbol 6
-#define CENTRY_handle_overflood 5
-#define CENTRY_handle_overflow 4
-#define CENTRY_handle_values_error 14
-#define CENTRY_install_library_entry 18
-#define CENTRY_instantiate_code_object 21
-#define CENTRY_raw_collect_cond 9
-#define CENTRY_raw_tc_mutex 10
-#define CENTRY_scan_remembered_set 20
-#define CENTRY_split_and_resize 8
-#define CENTRY_thread_context 0
-#define CENTRY_thread_list 7
-#define CENTRY_unactivate_thread 13
-
-/* displacements for records */
-#define eq_hashtable_rtd_disp 1
-#define eq_hashtable_type_disp 9
-#define eq_hashtable_mutablep_disp 17
-#define eq_hashtable_vec_disp 25
-#define eq_hashtable_minlen_disp 33
-#define eq_hashtable_size_disp 41
-#define eq_hashtable_subtype_disp 49
-#define symbol_hashtable_rtd_disp 1
-#define symbol_hashtable_type_disp 9
-#define symbol_hashtable_mutablep_disp 17
-#define symbol_hashtable_vec_disp 25
-#define symbol_hashtable_minlen_disp 33
-#define symbol_hashtable_size_disp 41
-#define symbol_hashtable_equivp_disp 49
-#define code_info_rtd_disp 1
-#define code_info_src_disp 9
-#define code_info_sexpr_disp 17
-#define code_info_free_disp 25
-#define code_info_live_disp 33
-#define code_info_rpis_disp 41
-
-/* predicates */
-#define Simmediatep(x) (((uptr)(x)&0x7)==0x6)
-#define Sportp(x) ((((uptr)(x)&0x7)==0x7) &&\
- (((uptr)((*((ptr *)((uptr)(x)+1))))&0xFF)==0x1E))
-#define Scodep(x) ((((uptr)(x)&0x7)==0x7) &&\
- (((uptr)((*((ptr *)((uptr)(x)+1))))&0xFF)==0x3E))
-
-/* structure accessors */
-#define INITCAR(x) (*((ptr *)((uptr)(x)+7)))
-#define INITCDR(x) (*((ptr *)((uptr)(x)+15)))
-#define SETCAR(x,y) DIRTYSET(((ptr *)((uptr)(x)+7)),(y))
-#define SETCDR(x,y) DIRTYSET(((ptr *)((uptr)(x)+15)),(y))
-#define BOXTYPE(x) (*((iptr *)((uptr)(x)+1)))
-#define INITBOXREF(x) (*((ptr *)((uptr)(x)+9)))
-#define SETBOXREF(x,y) DIRTYSET(((ptr *)((uptr)(x)+9)),(y))
-#define EPHEMERONNEXT(x) (*((ptr *)((uptr)(x)+23)))
-#define INITEPHEMERONNEXT(x) (*((ptr *)((uptr)(x)+23)))
-#define EPHEMERONTRIGGERNEXT(x) (*((ptr *)((uptr)(x)+31)))
-#define INITEPHEMERONTRIGGERNEXT(x) (*((ptr *)((uptr)(x)+31)))
-#define TLCTYPE(x) (*((iptr *)((uptr)(x)+1)))
-#define TLCKEYVAL(x) (*((ptr *)((uptr)(x)+9)))
-#define TLCHT(x) (*((ptr *)((uptr)(x)+17)))
-#define TLCNEXT(x) (*((ptr *)((uptr)(x)+25)))
-#define INITTLCKEYVAL(x) (*((ptr *)((uptr)(x)+9)))
-#define INITTLCHT(x) (*((ptr *)((uptr)(x)+17)))
-#define INITTLCNEXT(x) (*((ptr *)((uptr)(x)+25)))
-#define SETTLCNEXT(x,y) DIRTYSET(((ptr *)((uptr)(x)+25)),(y))
-#define SYMVAL(x) (*((ptr *)((uptr)(x)+5)))
-#define SYMPVAL(x) (*((ptr *)((uptr)(x)+13)))
-#define SYMPLIST(x) (*((ptr *)((uptr)(x)+21)))
-#define SYMNAME(x) (*((ptr *)((uptr)(x)+29)))
-#define SYMSPLIST(x) (*((ptr *)((uptr)(x)+37)))
-#define SYMHASH(x) (*((ptr *)((uptr)(x)+45)))
-#define INITSYMVAL(x) (*((ptr *)((uptr)(x)+5)))
-#define INITSYMPVAL(x) (*((ptr *)((uptr)(x)+13)))
-#define INITSYMPLIST(x) (*((ptr *)((uptr)(x)+21)))
-#define INITSYMNAME(x) (*((ptr *)((uptr)(x)+29)))
-#define INITSYMSPLIST(x) (*((ptr *)((uptr)(x)+37)))
-#define INITSYMHASH(x) (*((ptr *)((uptr)(x)+45)))
-#define SETSYMVAL(x,y) DIRTYSET(((ptr *)((uptr)(x)+5)),(y))
-#define SETSYMPVAL(x,y) DIRTYSET(((ptr *)((uptr)(x)+13)),(y))
-#define SETSYMPLIST(x,y) DIRTYSET(((ptr *)((uptr)(x)+21)),(y))
-#define SETSYMNAME(x,y) DIRTYSET(((ptr *)((uptr)(x)+29)),(y))
-#define SETSYMSPLIST(x,y) DIRTYSET(((ptr *)((uptr)(x)+37)),(y))
-#define SETSYMHASH(x,y) DIRTYSET(((ptr *)((uptr)(x)+45)),(y))
-#define VECTTYPE(x) (*((iptr *)((uptr)(x)+1)))
-#define INITVECTIT(x,i) (((ptr *)((uptr)(x)+9))[i])
-#define SETVECTIT(x,i,y) DIRTYSET((((ptr *)((uptr)(x)+9))+i),(y))
-#define FXVECTOR_TYPE(x) (*((iptr *)((uptr)(x)+1)))
-#define FXVECTIT(x,i) (((ptr *)((uptr)(x)+9))[i])
-#define BYTEVECTOR_TYPE(x) (*((iptr *)((uptr)(x)+1)))
-#define BVIT(x,i) (((octet *)((uptr)(x)+9))[i])
-#define INEXACTNUM_TYPE(x) (*((iptr *)((uptr)(x)+1)))
-#define INEXACTNUM_REAL_PART(x) (*((double *)((uptr)(x)+17)))
-#define INEXACTNUM_IMAG_PART(x) (*((double *)((uptr)(x)+25)))
-#define EXACTNUM_TYPE(x) (*((iptr *)((uptr)(x)+1)))
-#define EXACTNUM_REAL_PART(x) (*((ptr *)((uptr)(x)+9)))
-#define EXACTNUM_IMAG_PART(x) (*((ptr *)((uptr)(x)+17)))
-#define RATTYPE(x) (*((iptr *)((uptr)(x)+1)))
-#define RATNUM(x) (*((ptr *)((uptr)(x)+9)))
-#define RATDEN(x) (*((ptr *)((uptr)(x)+17)))
-#define CLOSENTRY(x) (*((ptr *)((uptr)(x)+3)))
-#define CLOSIT(x,i) (((ptr *)((uptr)(x)+11))[i])
-#define FLODAT(x) (*((double *)((uptr)(x)+6)))
-#define PORTTYPE(x) (*((iptr *)((uptr)(x)+1)))
-#define PORTNAME(x) (*((ptr *)((uptr)(x)+73)))
-#define PORTHANDLER(x) (*((ptr *)((uptr)(x)+9)))
-#define PORTINFO(x) (*((ptr *)((uptr)(x)+65)))
-#define PORTOCNT(x) (*((iptr *)((uptr)(x)+17)))
-#define PORTOLAST(x) (*((ptr *)((uptr)(x)+33)))
-#define PORTOBUF(x) (*((ptr *)((uptr)(x)+41)))
-#define PORTICNT(x) (*((iptr *)((uptr)(x)+25)))
-#define PORTILAST(x) (*((ptr *)((uptr)(x)+49)))
-#define PORTIBUF(x) (*((ptr *)((uptr)(x)+57)))
-#define STRTYPE(x) (*((iptr *)((uptr)(x)+1)))
-#define STRIT(x,i) (((string_char *)((uptr)(x)+9))[i])
-#define BIGTYPE(x) (*((iptr *)((uptr)(x)+1)))
-#define BIGIT(x,i) (((bigit *)((uptr)(x)+9))[i])
-#define CODETYPE(x) (*((iptr *)((uptr)(x)+1)))
-#define CODELEN(x) (*((iptr *)((uptr)(x)+9)))
-#define CODERELOC(x) (*((ptr *)((uptr)(x)+17)))
-#define CODENAME(x) (*((ptr *)((uptr)(x)+25)))
-#define CODEARITYMASK(x) (*((ptr *)((uptr)(x)+33)))
-#define CODEFREE(x) (*((iptr *)((uptr)(x)+41)))
-#define CODEINFO(x) (*((ptr *)((uptr)(x)+49)))
-#define CODEPINFOS(x) (*((ptr *)((uptr)(x)+57)))
-#define CODEIT(x,i) (((octet *)((uptr)(x)+65))[i])
-#define RELOCSIZE(x) (*((iptr *)((uptr)(x)+0)))
-#define RELOCCODE(x) (*((ptr *)((uptr)(x)+8)))
-#define RELOCIT(x,i) (((uptr *)((uptr)(x)+16))[i])
-#define CONTSTACK(x) (*((ptr *)((uptr)(x)+11)))
-#define CONTLENGTH(x) (*((iptr *)((uptr)(x)+19)))
-#define CONTCLENGTH(x) (*((iptr *)((uptr)(x)+27)))
-#define CONTLINK(x) (*((ptr *)((uptr)(x)+35)))
-#define CONTRET(x) (*((ptr *)((uptr)(x)+43)))
-#define CONTWINDERS(x) (*((ptr *)((uptr)(x)+51)))
-#define RTDCOUNTSTYPE(x) (*((iptr *)((uptr)(x)+1)))
-#define RTDCOUNTSTIMESTAMP(x) (*((U64 *)((uptr)(x)+9)))
-#define RTDCOUNTSIT(x,i) (((uptr *)((uptr)(x)+17))[i])
-#define RECORDDESCPARENT(x) (*((ptr *)((uptr)(x)+9)))
-#define RECORDDESCSIZE(x) (*((ptr *)((uptr)(x)+17)))
-#define RECORDDESCPM(x) (*((ptr *)((uptr)(x)+25)))
-#define RECORDDESCMPM(x) (*((ptr *)((uptr)(x)+33)))
-#define RECORDDESCNAME(x) (*((ptr *)((uptr)(x)+41)))
-#define RECORDDESCFLDS(x) (*((ptr *)((uptr)(x)+49)))
-#define RECORDDESCFLAGS(x) (*((ptr *)((uptr)(x)+57)))
-#define RECORDDESCUID(x) (*((ptr *)((uptr)(x)+65)))
-#define RECORDDESCCOUNTS(x) (*((ptr *)((uptr)(x)+73)))
-#define RECORDINSTTYPE(x) (*((ptr *)((uptr)(x)+1)))
-#define RECORDINSTIT(x,i) (((ptr *)((uptr)(x)+9))[i])
-#define CLOSCODE(p) ((ptr)((uptr)CLOSENTRY(p)-code_data_disp))
-#define CODEENTRYPOINT(x) ((ptr)((uptr)(x)+code_data_disp))
-#define SETCLOSCODE(p,x) (CLOSENTRY(p) = CODEENTRYPOINT(x))
-#define SYMCODE(p) ((ptr)((uptr)SYMPVAL(p)-code_data_disp))
-#define INITSYMCODE(p,x) (INITSYMPVAL(p) = CODEENTRYPOINT(x))
-#define SETSYMCODE(p,x) SETSYMPVAL(p,CODEENTRYPOINT(x))
-#define BIGLEN(x) ((iptr)((uptr)BIGTYPE(x) >> bignum_length_offset))
-#define BIGSIGN(x) ((BIGTYPE(x) & mask_bignum_sign) >> bignum_sign_offset)
-#define SETBIGLENANDSIGN(x,xl,xs) BIGTYPE(x) = (uptr)(xl) << bignum_length_offset | (xs) << bignum_sign_offset | type_bignum
-#define CLOSLEN(p) CODEFREE(CLOSCODE(p))
-#define GUARDIANOBJ(x) (*((ptr *)((uptr)(x)+0)))
-#define GUARDIANREP(x) (*((ptr *)((uptr)(x)+8)))
-#define GUARDIANTCONC(x) (*((ptr *)((uptr)(x)+16)))
-#define GUARDIANNEXT(x) (*((ptr *)((uptr)(x)+24)))
-#define INITGUARDIANOBJ(x) (*((ptr *)((uptr)(x)+0)))
-#define INITGUARDIANREP(x) (*((ptr *)((uptr)(x)+8)))
-#define INITGUARDIANTCONC(x) (*((ptr *)((uptr)(x)+16)))
-#define INITGUARDIANNEXT(x) (*((ptr *)((uptr)(x)+24)))
-#define FORWARDMARKER(x) (*((ptr *)((uptr)(x)+0)))
-#define FORWARDADDRESS(x) (*((ptr *)((uptr)(x)+8)))
-#define CACHEDSTACKSIZE(x) (*((iptr *)((uptr)(x)+0)))
-#define CACHEDSTACKLINK(x) (*((ptr *)((uptr)(x)+8)))
-#define RPHEADERFRAMESIZE(x) (*((iptr *)((uptr)(x)+16)))
-#define RPHEADERLIVEMASK(x) (*((ptr *)((uptr)(x)+0)))
-#define RPHEADERTOPLINK(x) (*((uptr *)((uptr)(x)+8)))
-
-/* machine types */
-#define machine_type_names {"any", "i3le", "ti3le", "i3nt", "ti3nt", "i3fb", "ti3fb", "i3ob", "ti3ob", "i3osx", "ti3osx", "a6le", "ta6le", "a6osx", "ta6osx", "a6ob", "ta6ob", "a6s2", "ta6s2", "i3s2", "ti3s2", "a6fb", "ta6fb", "i3nb", "ti3nb", "a6nb", "ta6nb", "a6nt", "ta6nt", "i3qnx", "ti3qnx", "arm32le", "tarm32le", "ppc32le", "tppc32le"}
-
-/* allocation-space names */
-#define alloc_space_names "new", "impure", "symbol", "port", "weakpr", "emph", "pure", "cont", "code", "p-tobj", "ip-rec", "data", "empty"
-
-/* allocation-space characters */
-#define alloc_space_chars 'n', 'i', 'x', 'q', 'w', 'e', 'p', 'k', 'c', 'r', 's', 'd', 'e'
-
-/* threads */
-#define THREADTC(x) (*((uptr *)((uptr)(x)+9)))
-
-/* thread-context data */
-#define DSTBV(x) (*((ptr *)((uptr)(x)+680)))
-#define SRCBV(x) (*((ptr *)((uptr)(x)+688)))
-#define U(x) (*((ptr *)((uptr)(x)+352)))
-#define V(x) (*((ptr *)((uptr)(x)+360)))
-#define W(x) (*((ptr *)((uptr)(x)+368)))
-#define X(x) (*((ptr *)((uptr)(x)+376)))
-#define Y(x) (*((ptr *)((uptr)(x)+384)))
-#define AC0(x) (*((void* *)((uptr)(x)+40)))
-#define AC1(x) (*((void* *)((uptr)(x)+48)))
-#define ACTIVE(x) (*((I32 *)((uptr)(x)+308)))
-#define ALLOCCOUNTER(x) (*((U64 *)((uptr)(x)+664)))
-#define AP(x) (*((void* *)((uptr)(x)+80)))
-#define ARGREGS(x,i) (((void* *)((uptr)(x)+0))[i])
-#define BLOCKCOUNTER(x) (*((ptr *)((uptr)(x)+472)))
-#define CCHAIN(x) (*((ptr *)((uptr)(x)+288)))
-#define CODERANGESTOFLUSH(x) (*((ptr *)((uptr)(x)+296)))
-#define COMPILEPROFILE(x) (*((ptr *)((uptr)(x)+560)))
-#define COMPRESSFORMAT(x) (*((ptr *)((uptr)(x)+632)))
-#define COMPRESSLEVEL(x) (*((ptr *)((uptr)(x)+640)))
-#define CP(x) (*((void* *)((uptr)(x)+64)))
-#define CURRENTERROR(x) (*((ptr *)((uptr)(x)+464)))
-#define CURRENTINPUT(x) (*((ptr *)((uptr)(x)+448)))
-#define CURRENTMSO(x) (*((ptr *)((uptr)(x)+488)))
-#define CURRENTOUTPUT(x) (*((ptr *)((uptr)(x)+456)))
-#define DEFAULTRECORDEQUALPROCEDURE(x) (*((ptr *)((uptr)(x)+616)))
-#define DEFAULTRECORDHASHPROCEDURE(x) (*((ptr *)((uptr)(x)+624)))
-#define DISABLECOUNT(x) (*((ptr *)((uptr)(x)+408)))
-#define EAP(x) (*((void* *)((uptr)(x)+88)))
-#define ESP(x) (*((void* *)((uptr)(x)+72)))
-#define FXFIRSTBITSETBV(x) (*((ptr *)((uptr)(x)+512)))
-#define FXLENGTHBV(x) (*((ptr *)((uptr)(x)+504)))
-#define GENERATEINSPECTORINFORMATION(x) (*((ptr *)((uptr)(x)+568)))
-#define GENERATEPROCEDURESOURCEINFORMATION(x) (*((ptr *)((uptr)(x)+576)))
-#define GENERATEPROFILEFORMS(x) (*((ptr *)((uptr)(x)+584)))
-#define GUARDIANENTRIES(x) (*((ptr *)((uptr)(x)+280)))
-#define INSTRCOUNTER(x) (*((U64 *)((uptr)(x)+656)))
-#define KEYBOARDINTERRUPTPENDING(x) (*((ptr *)((uptr)(x)+432)))
-#define LZ4OUTBUFFER(x) (*((void* *)((uptr)(x)+648)))
-#define METALEVEL(x) (*((ptr *)((uptr)(x)+552)))
-#define NULLIMMUTABLEBYTEVECTOR(x) (*((ptr *)((uptr)(x)+536)))
-#define NULLIMMUTABLEFXVECTOR(x) (*((ptr *)((uptr)(x)+528)))
-#define NULLIMMUTABLESTRING(x) (*((ptr *)((uptr)(x)+544)))
-#define NULLIMMUTABLEVECTOR(x) (*((ptr *)((uptr)(x)+520)))
-#define OPTIMIZELEVEL(x) (*((ptr *)((uptr)(x)+592)))
-#define PARAMETERS(x) (*((ptr *)((uptr)(x)+672)))
-#define RANDOMSEED(x) (*((U32 *)((uptr)(x)+304)))
-#define REAL_EAP(x) (*((void* *)((uptr)(x)+144)))
-#define RET(x) (*((void* *)((uptr)(x)+96)))
-#define SCHEMESTACK(x) (*((void* *)((uptr)(x)+312)))
-#define SCHEMESTACKSIZE(x) (*((iptr *)((uptr)(x)+336)))
-#define SFD(x) (*((ptr *)((uptr)(x)+480)))
-#define SFP(x) (*((void* *)((uptr)(x)+56)))
-#define SIGNALINTERRUPTPENDING(x) (*((ptr *)((uptr)(x)+416)))
-#define SIGNALINTERRUPTQUEUE(x) (*((ptr *)((uptr)(x)+424)))
-#define SOMETHINGPENDING(x) (*((ptr *)((uptr)(x)+392)))
-#define STACKCACHE(x) (*((ptr *)((uptr)(x)+320)))
-#define STACKLINK(x) (*((ptr *)((uptr)(x)+328)))
-#define SUBSETMODE(x) (*((ptr *)((uptr)(x)+600)))
-#define SUPPRESSPRIMITIVEINLINING(x) (*((ptr *)((uptr)(x)+608)))
-#define TARGETMACHINE(x) (*((ptr *)((uptr)(x)+496)))
-#define TD(x) (*((void* *)((uptr)(x)+136)))
-#define THREADNO(x) (*((ptr *)((uptr)(x)+440)))
-#define TIMERTICKS(x) (*((ptr *)((uptr)(x)+400)))
-#define TRAP(x) (*((void* *)((uptr)(x)+104)))
-#define TS(x) (*((void* *)((uptr)(x)+128)))
-#define VIRTUALREGISTERS(x,i) (((ptr *)((uptr)(x)+152))[i])
-#define WINDERS(x) (*((ptr *)((uptr)(x)+344)))
-#define XP(x) (*((void* *)((uptr)(x)+112)))
-#define YP(x) (*((void* *)((uptr)(x)+120)))
-#define ARGREG(x,i) (((void* *)((uptr)(x)+0))[i])
-#define VIRTREG(x,i) (((ptr *)((uptr)(x)+152))[i])
-
-/* library entries we access from C code */
-#define library_nonprocedure_code 152
-#define library_dounderflow 154
diff --git a/ta6ob/boot/ta6ob/kernel.o b/ta6ob/boot/ta6ob/kernel.o
deleted file mode 100644
index 18f2ee2..0000000
Binary files a/ta6ob/boot/ta6ob/kernel.o and /dev/null differ
diff --git a/ta6ob/boot/ta6ob/main.o b/ta6ob/boot/ta6ob/main.o
deleted file mode 100644
index 5255463..0000000
Binary files a/ta6ob/boot/ta6ob/main.o and /dev/null differ
diff --git a/ta6ob/boot/ta6ob/petite.boot b/ta6ob/boot/ta6ob/petite.boot
deleted file mode 100644
index 38997ee..0000000
Binary files a/ta6ob/boot/ta6ob/petite.boot and /dev/null differ
diff --git a/ta6ob/boot/ta6ob/revision b/ta6ob/boot/ta6ob/revision
deleted file mode 100644
index e00319a..0000000
--- a/ta6ob/boot/ta6ob/revision
+++ /dev/null
@@ -1,2 +0,0 @@
-43e68af625b650124dc0a2c2f22fac26a3449c24
-git
diff --git a/ta6ob/boot/ta6ob/scheme.boot b/ta6ob/boot/ta6ob/scheme.boot
deleted file mode 100644
index c839f7d..0000000
Binary files a/ta6ob/boot/ta6ob/scheme.boot and /dev/null differ
diff --git a/ta6ob/boot/ta6ob/scheme.h b/ta6ob/boot/ta6ob/scheme.h
deleted file mode 100644
index 434b811..0000000
--- a/ta6ob/boot/ta6ob/scheme.h
+++ /dev/null
@@ -1,245 +0,0 @@
-/* scheme.h for Chez Scheme Version 9.5.9 (ta6ob) */
-
-/* Do not edit this file. It is automatically generated and */
-/* specifically tailored to the version of Chez Scheme named */
-/* above. Always be certain that you have the correct scheme.h */
-/* for the version of Chez Scheme you are using. */
-
-/* Warning: Some macros may evaluate arguments more than once. */
-
-/* Specify declaration of exports. */
-#ifdef _WIN32
-# if __cplusplus
-# ifdef SCHEME_IMPORT
-# define EXPORT extern "C" __declspec (dllimport)
-# elif SCHEME_STATIC
-# define EXPORT extern "C"
-# else
-# define EXPORT extern "C" __declspec (dllexport)
-# endif
-# else
-# ifdef SCHEME_IMPORT
-# define EXPORT extern __declspec (dllimport)
-# elif SCHEME_STATIC
-# define EXPORT extern
-# else
-# define EXPORT extern __declspec (dllexport)
-# endif
-# endif
-#else
-# if __cplusplus
-# define EXPORT extern "C"
-# else
-# define EXPORT extern
-# endif
-#endif
-
-/* Chez Scheme Version and machine type */
-#define VERSION "9.5.9"
-#define MACHINE_TYPE "ta6ob"
-
-/* All Scheme objects are of type ptr. Type iptr and */
-/* uptr are signed and unsigned ints of the same size */
-/* as a ptr */
-typedef void * ptr;
-typedef long int iptr;
-typedef unsigned long int uptr;
-
-/* String elements are 32-bit tagged char objects */
-typedef unsigned int string_char;
-
-/* Bytevector elements are 8-bit unsigned "octets" */
-typedef unsigned char octet;
-
-/* Type predicates */
-#define Sfixnump(x) (((uptr)(x)&0x7)==0x0)
-#define Scharp(x) (((uptr)(x)&0xFF)==0x16)
-#define Snullp(x) ((uptr)(x)==0x26)
-#define Seof_objectp(x) ((uptr)(x)==0x36)
-#define Sbwp_objectp(x) ((uptr)(x)==0x4E)
-#define Sbooleanp(x) (((uptr)(x)&0xF7)==0x6)
-#define Spairp(x) (((uptr)(x)&0x7)==0x1)
-#define Ssymbolp(x) (((uptr)(x)&0x7)==0x3)
-#define Sprocedurep(x) (((uptr)(x)&0x7)==0x5)
-#define Sflonump(x) (((uptr)(x)&0x7)==0x2)
-#define Svectorp(x) ((((uptr)(x)&0x7)==0x7) &&\
- (((uptr)((*((ptr *)((uptr)(x)+1))))&0x7)==0x0))
-#define Sfxvectorp(x) ((((uptr)(x)&0x7)==0x7) &&\
- (((uptr)((*((ptr *)((uptr)(x)+1))))&0x7)==0x3))
-#define Sbytevectorp(x) ((((uptr)(x)&0x7)==0x7) &&\
- (((uptr)((*((ptr *)((uptr)(x)+1))))&0x3)==0x1))
-#define Sstringp(x) ((((uptr)(x)&0x7)==0x7) &&\
- (((uptr)((*((ptr *)((uptr)(x)+1))))&0x7)==0x2))
-#define Sbignump(x) ((((uptr)(x)&0x7)==0x7) &&\
- (((uptr)((*((ptr *)((uptr)(x)+1))))&0x1F)==0x6))
-#define Sboxp(x) ((((uptr)(x)&0x7)==0x7) &&\
- (((uptr)((*((ptr *)((uptr)(x)+1))))&0x7F)==0xE))
-#define Sinexactnump(x) ((((uptr)(x)&0x7)==0x7) &&\
- ((uptr)((*((ptr *)((uptr)(x)+1))))==0x36))
-#define Sexactnump(x) ((((uptr)(x)&0x7)==0x7) &&\
- ((uptr)((*((ptr *)((uptr)(x)+1))))==0x56))
-#define Sratnump(x) ((((uptr)(x)&0x7)==0x7) &&\
- ((uptr)((*((ptr *)((uptr)(x)+1))))==0x16))
-#define Sinputportp(x) ((((uptr)(x)&0x7)==0x7) &&\
- (((uptr)((*((ptr *)((uptr)(x)+1))))&0x1FF)==0x11E))
-#define Soutputportp(x) ((((uptr)(x)&0x7)==0x7) &&\
- (((uptr)((*((ptr *)((uptr)(x)+1))))&0x2FF)==0x21E))
-#define Srecordp(x) ((((uptr)(x)&0x7)==0x7) &&\
- (((uptr)((*((ptr *)((uptr)(x)+1))))&0x7)==0x7))
-
-/* Accessors */
-#define Sfixnum_value(x) ((iptr)(x)/8)
-#define Schar_value(x) ((string_char)((uptr)(x)>>8))
-#define Sboolean_value(x) ((x) != Sfalse)
-#define Scar(x) (*((ptr *)((uptr)(x)+7)))
-#define Scdr(x) (*((ptr *)((uptr)(x)+15)))
-#define Sflonum_value(x) (*((double *)((uptr)(x)+6)))
-#define Svector_length(x) ((iptr)((uptr)(*((iptr *)((uptr)(x)+1)))>>4))
-#define Svector_ref(x,i) (((ptr *)((uptr)(x)+9))[i])
-#define Sfxvector_length(x) ((iptr)((uptr)(*((iptr *)((uptr)(x)+1)))>>4))
-#define Sfxvector_ref(x,i) (((ptr *)((uptr)(x)+9))[i])
-#define Sbytevector_length(x) ((iptr)((uptr)(*((iptr *)((uptr)(x)+1)))>>3))
-#define Sbytevector_u8_ref(x,i) (((octet *)((uptr)(x)+9))[i])
-/* Warning: Sbytevector_data(x) returns a pointer into x. */
-#define Sbytevector_data(x) &Sbytevector_u8_ref(x,0)
-#define Sstring_length(x) ((iptr)((uptr)(*((iptr *)((uptr)(x)+1)))>>4))
-#define Sstring_ref(x,i) Schar_value(((string_char *)((uptr)(x)+9))[i])
-#define Sunbox(x) (*((ptr *)((uptr)(x)+9)))
-EXPORT iptr Sinteger_value(ptr);
-#define Sunsigned_value(x) (uptr)Sinteger_value(x)
-EXPORT int Sinteger32_value(ptr);
-#define Sunsigned32_value(x) (unsigned int)Sinteger32_value(x)
-EXPORT long Sinteger64_value(ptr);
-#define Sunsigned64_value(x) (unsigned long)Sinteger64_value(x)
-
-/* Mutators */
-EXPORT void Sset_box(ptr, ptr);
-EXPORT void Sset_car(ptr, ptr);
-EXPORT void Sset_cdr(ptr, ptr);
-#define Sstring_set(x,i,c) ((void)((((string_char *)((uptr)(x)+9))[i]) = (string_char)(uptr)Schar(c)))
-#define Sfxvector_set(x,i,n) ((void)(Sfxvector_ref(x,i) = (n)))
-#define Sbytevector_u8_set(x,i,n) ((void)(Sbytevector_u8_ref(x,i) = (n)))
-EXPORT void Svector_set(ptr, iptr, ptr);
-
-/* Constructors */
-#define Sfixnum(x) ((ptr)(uptr)((x)*8))
-#define Schar(x) ((ptr)(uptr)((x)<<8|0x16))
-#define Snil ((ptr)0x26)
-#define Strue ((ptr)0xE)
-#define Sfalse ((ptr)0x6)
-#define Sboolean(x) ((x)?Strue:Sfalse)
-#define Sbwp_object ((ptr)0x4E)
-#define Seof_object ((ptr)0x36)
-#define Svoid ((ptr)0x3E)
-EXPORT ptr Scons(ptr, ptr);
-EXPORT ptr Sstring_to_symbol(const char *);
-EXPORT ptr Ssymbol_to_string(ptr);
-EXPORT ptr Sflonum(double);
-EXPORT ptr Smake_vector(iptr, ptr);
-EXPORT ptr Smake_fxvector(iptr, ptr);
-EXPORT ptr Smake_bytevector(iptr, int);
-EXPORT ptr Smake_string(iptr, int);
-EXPORT ptr Smake_uninitialized_string(iptr);
-EXPORT ptr Sstring(const char *);
-EXPORT ptr Sstring_of_length(const char *, iptr);
-EXPORT ptr Sstring_utf8(const char*, iptr);
-EXPORT ptr Sbox(ptr);
-EXPORT ptr Sinteger(iptr);
-EXPORT ptr Sunsigned(uptr);
-EXPORT ptr Sinteger32(int);
-EXPORT ptr Sunsigned32(unsigned int);
-EXPORT ptr Sinteger64(long);
-EXPORT ptr Sunsigned64(unsigned long);
-
-/* Miscellaneous */
-EXPORT ptr Stop_level_value(ptr);
-EXPORT void Sset_top_level_value(ptr, ptr);
-EXPORT void Slock_object(ptr);
-EXPORT void Sunlock_object(ptr);
-EXPORT int Slocked_objectp(ptr);
-EXPORT void Sforeign_symbol(const char *, void *);
-EXPORT void Sregister_symbol(const char *, void *);
-
-/* Support for calls into Scheme */
-EXPORT ptr Scall0(ptr);
-EXPORT ptr Scall1(ptr, ptr);
-EXPORT ptr Scall2(ptr, ptr, ptr);
-EXPORT ptr Scall3(ptr, ptr, ptr, ptr);
-EXPORT void Sinitframe(iptr);
-EXPORT void Sput_arg(iptr, ptr);
-EXPORT ptr Scall(ptr, iptr);
-/* Warning: Sforeign_callable_entry_point(x) returns a pointer into x. */
-#define Sforeign_callable_entry_point(x) ((void (*)(void))((uptr)(x)+65))
-#define Sforeign_callable_code_object(x) ((ptr)((uptr)(x)-65))
-
-/* Customization support. */
-EXPORT const char * Skernel_version(void);
-EXPORT void Sretain_static_relocation(void);
-EXPORT void Sset_verbose(int);
-EXPORT void Sscheme_init(void (*)(void));
-EXPORT void Sregister_boot_file(const char *);
-EXPORT void Sregister_boot_file_fd(const char *, int fd);
-EXPORT void Sregister_heap_file(const char *);
-EXPORT void Scompact_heap(void);
-EXPORT void Ssave_heap(const char *, int);
-EXPORT void Sbuild_heap(const char *, void (*)(void));
-EXPORT void Senable_expeditor(const char *);
-EXPORT int Sscheme_start(int, const char *[]);
-EXPORT int Sscheme_script(const char *, int, const char *[]);
-EXPORT int Sscheme_program(const char *, int, const char *[]);
-EXPORT void Sscheme_deinit(void);
-
-/* Thread support. */
-EXPORT int Sactivate_thread(void);
-EXPORT void Sdeactivate_thread(void);
-EXPORT int Sdestroy_thread(void);
-
-/* Features. */
-#define FEATURE_ICONV
-#define FEATURE_EXPEDITOR
-#define FEATURE_PTHREADS
-
-/* Locking macros. */
-#define INITLOCK(addr) \
- __asm__ __volatile__ ("movq $0, (%0)"\
- : \
- : "r" (addr) \
- : "memory")
-
-#define SPINLOCK(addr) \
- __asm__ __volatile__ ("0:\n\t"\
- "movq $1, %%rax\n\t"\
- "xchgq (%0), %%rax\n\t"\
- "cmpq $0, %%rax\n\t"\
- "je 2f\n\t"\
- "1:\n\t"\
- "pause\n\t"\
- "cmpq $0, (%0)\n\t"\
- "je 0b\n\t"\
- "jmp 1b\n\t"\
- "2:"\
- : \
- : "r" (addr) \
- : "rax", "flags", "memory")
-
-#define UNLOCK(addr) \
- __asm__ __volatile__ ("movq $0, (%0)"\
- : \
- : "r" (addr) \
- :"memory")
-
-#define LOCKED_INCR(addr, ret) \
- __asm__ __volatile__ ("lock; incq (%1)\n\t"\
- "sete %b0\n\t"\
- "movzx %b0, %0\n\t"\
- : "=q" (ret) \
- : "r" (addr) \
- : "flags", "memory")
-
-#define LOCKED_DECR(addr, ret) \
- __asm__ __volatile__ ("lock; decq (%1)\n\t"\
- "sete %b0\n\t"\
- "movzx %b0, %0\n\t"\
- : "=q" (ret) \
- : "r" (addr) \
- : "flags", "memory")
diff --git a/ta6ob/c/Makefile b/ta6ob/c/Makefile
deleted file mode 100644
index 74857da..0000000
--- a/ta6ob/c/Makefile
+++ /dev/null
@@ -1,47 +0,0 @@
-# Mf-ta6ob
-# Copyright 1984-2017 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.
-
-m = ta6ob
-Cpu = X86_64
-
-mdinclude = -I/usr/local/include -I/usr/X11R6/include
-mdclib = -L/usr/local/lib -liconv -lm ${ncursesLib} -lpthread -lossp-uuid
-C = ${CC} ${CPPFLAGS} -Wpointer-arith -Werror -O2 -D_REENTRANT -pthread ${CFLAGS}
-o = o
-mdsrc = i3le.c
-mdobj = i3le.o
-
-.SUFFIXES:
-.SUFFIXES: .c .o
-
-.c.o:
- $C -c -D${Cpu} -I${Include} ${zlibInc} ${LZ4Inc} ${mdinclude} $*.c
-
-include Mf-base
-
-${KernelO}: ${kernelobj} ${zlibDep} ${LZ4Dep}
- ${LD} -r -X -o ${KernelO} ${kernelobj} ${zlibLib} ${LZ4Lib}
-
-${KernelLib}: ${kernelobj}
- ${AR} ${ARFLAGS} ${KernelLib} ${kernelobj}
-
-${Scheme}: ${Kernel} ${KernelLinkDeps} ${Main}
- $C -rdynamic -Wl,--export-dynamic -Wl,-zwxneeded -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS}
-
-../zlib/configure.log:
- (cd ../zlib; CFLAGS="${CFLAGS} -m64" ./configure --64)
-
-../lz4/lib/liblz4.a: ${LZ4Sources}
- (cd ../lz4/lib; CFLAGS="${CFLAGS} -m64" ${MAKE} liblz4.a)
diff --git a/ta6ob/c/Mf-base b/ta6ob/c/Mf-base
deleted file mode 100644
index d97cf91..0000000
--- a/ta6ob/c/Mf-base
+++ /dev/null
@@ -1,82 +0,0 @@
-# Mf-base
-# Copyright 1984-2017 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.
-
-include Mf-config
-export CC CFLAGS LD LDFLAGS
-
-Include=../boot/$m
-PetiteBoot=../boot/$m/petite.boot
-SchemeBoot=../boot/$m/scheme.boot
-Main=../boot/$m/main.$o
-Scheme=../bin/$m/scheme
-
-# One of these sets is referenced in Mf-config to select between
-# linking with kernel.o or libkernel.a
-
-KernelO=../boot/$m/kernel.$o
-KernelOLinkDeps=
-KernelOLinkLibs=
-
-KernelLib=../boot/$m/libkernel.a
-KernelLibLinkDeps=${zlibDep} ${LZ4Dep}
-KernelLibLinkLibs=${zlibLib} ${LZ4Lib}
-
-kernelsrc=statics.c segment.c alloc.c symbol.c intern.c gcwrapper.c gc-011.c gc-ocd.c gc-oce.c\
- number.c schsig.c io.c new-io.c print.c fasl.c stats.c foreign.c prim.c prim5.c flushcache.c\
- schlib.c thread.c expeditor.c scheme.c compress-io.c
-
-kernelobj=${kernelsrc:%.c=%.$o} ${mdobj}
-
-kernelhdr=system.h types.h version.h globals.h externs.h segment.h gc.c sort.h thread.h config.h compress-io.h itest.c nocurses.h
-
-mainsrc=main.c
-
-mainobj:=${mainsrc:%.c=%.$o}
-
-doit: ${Scheme}
-
-source: ${kernelsrc} ${kernelhdr} ${mdsrc} ${mainsrc}
-
-${Main}: ${mainobj}
- cp -p ${mainobj} ${Main}
-
-rootsrc=$(shell cd ../../c; echo *)
-${rootsrc}:
-ifeq ($(OS),Windows_NT)
- cp -p ../../c/$@ $@
-else
- ln -s ../../c/$@ $@
-endif
-
-scheme.o: itest.c
-scheme.o main.o: config.h
-${kernelobj}: system.h types.h version.h externs.h globals.h segment.h thread.h sort.h compress-io.h nocurses.h
-${kernelobj}: ${Include}/equates.h ${Include}/scheme.h
-${mainobj}: ${Include}/scheme.h
-${kernelobj}: ${zlibHeaderDep} ${LZ4HeaderDep}
-gc-011.o gc-ocd.o gc-oce.o: gc.c
-
-../zlib/zlib.h ../zlib/zconf.h: ../zlib/configure.log
-
-../zlib/libz.a: ../zlib/configure.log
- (cd ../zlib; ${MAKE})
-
-LZ4Sources=../lz4/lib/lz4.h ../lz4/lib/lz4frame.h \
- ../lz4/lib/lz4.c ../lz4/lib/lz4frame.c \
- ../lz4/lib/lz4hc.c ../lz4/lib/xxhash.c
-
-clean:
- rm -f *.$o ${mdclean}
- rm -f Make.out
diff --git a/ta6ob/c/Mf-config b/ta6ob/c/Mf-config
deleted file mode 100644
index 168f559..0000000
--- a/ta6ob/c/Mf-config
+++ /dev/null
@@ -1,22 +0,0 @@
-CC=gcc
-CPPFLAGS=
-CFLAGS=
-LD=ld
-LDFLAGS=
-AR=ar
-ARFLAGS=rc
-RANLIB=ranlib
-WINDRES=windres
-cursesLib=-lcurses
-ncursesLib=-lncurses
-zlibInc=-I../zlib
-LZ4Inc=-I../lz4/lib
-zlibDep=../zlib/libz.a
-LZ4Dep=../lz4/lib/liblz4.a
-zlibLib=../zlib/libz.a
-LZ4Lib=../lz4/lib/liblz4.a
-zlibHeaderDep=../zlib/zconf.h ../zlib/zlib.h
-LZ4HeaderDep=../lz4/lib/lz4.h ../lz4/lib/lz4frame.h
-Kernel=${KernelO}
-KernelLinkDeps=${KernelOLinkDeps}
-KernelLinkLibs=${KernelOLinkLibs}
diff --git a/ta6ob/c/Mf-ta6ob b/ta6ob/c/Mf-ta6ob
deleted file mode 100644
index 74857da..0000000
--- a/ta6ob/c/Mf-ta6ob
+++ /dev/null
@@ -1,47 +0,0 @@
-# Mf-ta6ob
-# Copyright 1984-2017 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.
-
-m = ta6ob
-Cpu = X86_64
-
-mdinclude = -I/usr/local/include -I/usr/X11R6/include
-mdclib = -L/usr/local/lib -liconv -lm ${ncursesLib} -lpthread -lossp-uuid
-C = ${CC} ${CPPFLAGS} -Wpointer-arith -Werror -O2 -D_REENTRANT -pthread ${CFLAGS}
-o = o
-mdsrc = i3le.c
-mdobj = i3le.o
-
-.SUFFIXES:
-.SUFFIXES: .c .o
-
-.c.o:
- $C -c -D${Cpu} -I${Include} ${zlibInc} ${LZ4Inc} ${mdinclude} $*.c
-
-include Mf-base
-
-${KernelO}: ${kernelobj} ${zlibDep} ${LZ4Dep}
- ${LD} -r -X -o ${KernelO} ${kernelobj} ${zlibLib} ${LZ4Lib}
-
-${KernelLib}: ${kernelobj}
- ${AR} ${ARFLAGS} ${KernelLib} ${kernelobj}
-
-${Scheme}: ${Kernel} ${KernelLinkDeps} ${Main}
- $C -rdynamic -Wl,--export-dynamic -Wl,-zwxneeded -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS}
-
-../zlib/configure.log:
- (cd ../zlib; CFLAGS="${CFLAGS} -m64" ./configure --64)
-
-../lz4/lib/liblz4.a: ${LZ4Sources}
- (cd ../lz4/lib; CFLAGS="${CFLAGS} -m64" ${MAKE} liblz4.a)
diff --git a/ta6ob/c/alloc.c b/ta6ob/c/alloc.c
deleted file mode 100644
index cb7c967..0000000
--- a/ta6ob/c/alloc.c
+++ /dev/null
@@ -1,862 +0,0 @@
-/* alloc.c
- * Copyright 1984-2017 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.
- */
-
-#include "system.h"
-
-/* locally defined functions */
-static void maybe_fire_collector(void);
-
-void S_alloc_init(void) {
- ISPC s; IGEN g; UINT i;
-
- if (S_boot_time) {
- /* reset the allocation tables */
- for (g = 0; g <= static_generation; g++) {
- S_G.bytes_of_generation[g] = 0;
- for (s = 0; s <= max_real_space; s++) {
- S_G.base_loc[g][s] = FIX(0);
- S_G.first_loc[g][s] = FIX(0);
- S_G.next_loc[g][s] = FIX(0);
- S_G.bytes_left[g][s] = 0;
- S_G.bytes_of_space[g][s] = 0;
- }
- }
-
- /* initialize the dirty-segment lists. */
- for (i = 0; i < DIRTY_SEGMENT_LISTS; i += 1) {
- S_G.dirty_segments[i] = NULL;
- }
-
- S_G.collect_trip_bytes = default_collect_trip_bytes;
- S_G.g0_bytes_after_last_gc = 0;
-
- /* set to final value in prim.c when known */
- S_protect(&S_G.nonprocedure_code);
- S_G.nonprocedure_code = FIX(0);
-
- S_protect(&S_G.null_vector);
- find_room(space_new, 0, type_typed_object, size_vector(0), S_G.null_vector);
- VECTTYPE(S_G.null_vector) = (0 << vector_length_offset) | type_vector;
-
- S_protect(&S_G.null_fxvector);
- find_room(space_new, 0, type_typed_object, size_fxvector(0), S_G.null_fxvector);
- FXVECTOR_TYPE(S_G.null_fxvector) = (0 << fxvector_length_offset) | type_fxvector;
-
- S_protect(&S_G.null_bytevector);
- find_room(space_new, 0, type_typed_object, size_bytevector(0), S_G.null_bytevector);
- BYTEVECTOR_TYPE(S_G.null_bytevector) = (0 << bytevector_length_offset) | type_bytevector;
-
- S_protect(&S_G.null_string);
- find_room(space_new, 0, type_typed_object, size_string(0), S_G.null_string);
- STRTYPE(S_G.null_string) = (0 << string_length_offset) | type_string;
- }
-}
-
-void S_protect(ptr *p) {
- if (S_G.protect_next > max_protected)
- S_error_abort("max_protected constant too small");
- *p = snil;
- S_G.protected[S_G.protect_next++] = p;
-}
-
-/* S_reset_scheme_stack is always called with mutex */
-void S_reset_scheme_stack(ptr tc, iptr n) {
- ptr *x; iptr m;
-
- /* we allow less than one_shot_headroom here for no truly justifiable
- reason */
- n = ptr_align(n + (one_shot_headroom >> 1));
-
- x = &STACKCACHE(tc);
- for (;;) {
- if (*x == snil) {
- if (n < default_stack_size) n = default_stack_size;
- /* stacks are untyped objects */
- find_room(space_new, 0, typemod, n, SCHEMESTACK(tc));
- break;
- }
- if ((m = CACHEDSTACKSIZE(*x)) >= n) {
- n = m;
- SCHEMESTACK(tc) = *x;
-/* if we decide to leave KEEPSMALLPUPPIES undefined permanently, we should
- rewrite this code to remove the indirect on x */
-/* #define KEEPSMALLPUPPIES */
-#ifdef KEEPSMALLPUPPIES
- *x = CACHEDSTACKLINK(*x);
-#else
- STACKCACHE(tc) = CACHEDSTACKLINK(*x);
-#endif
- break;
- }
- x = &CACHEDSTACKLINK(*x);
- }
- SCHEMESTACKSIZE(tc) = n;
- ESP(tc) = (ptr)((uptr)SCHEMESTACK(tc) + n - stack_slop);
- SFP(tc) = (ptr)SCHEMESTACK(tc);
-}
-
-ptr S_compute_bytes_allocated(ptr xg, ptr xs) {
- ptr tc = get_thread_context();
- ISPC s, smax, smin; IGEN g, gmax, gmin;
- uptr n;
-
- gmin = (IGEN)UNFIX(xg);
- if (gmin < 0) {
- gmin = 0;
- gmax = static_generation;
- } else if (gmin == S_G.new_max_nonstatic_generation) {
- /* include virtual inhabitents too */
- gmax = S_G.max_nonstatic_generation;
- } else {
- gmax = gmin;
- }
-
- smin = (ISPC)(UNFIX(xs));
- smax = smin < 0 ? max_real_space : smin;
- smin = smin < 0 ? 0 : smin;
-
- n = 0;
-
- g = gmin;
- while (g <= gmax) {
- for (s = smin; s <= smax; s++) {
- ptr next_loc = S_G.next_loc[g][s];
- /* add in bytes previously recorded */
- n += S_G.bytes_of_space[g][s];
- /* add in bytes in active segments */
- if (next_loc != FIX(0))
- n += (char *)next_loc - (char *)S_G.base_loc[g][s];
- }
- if (g == S_G.max_nonstatic_generation)
- g = static_generation;
- else
- g += 1;
- }
-
- /* subtract off bytes not allocated */
- if (gmin == 0 && smin <= space_new && space_new <= smax)
- n -= (uptr)REAL_EAP(tc) - (uptr)AP(tc);
-
- return Sunsigned(n);
-}
-
-static void maybe_fire_collector(void) {
- if (S_G.bytes_of_generation[0] - S_G.g0_bytes_after_last_gc >= S_G.collect_trip_bytes)
- S_fire_collector();
-}
-
-/* find_more_room
- * S_find_more_room is called from the macro find_room when
- * the current segment is too full to fit the allocation.
- *
- * A forward_marker followed by a pointer to
- * the newly obtained segment is placed at next_loc to show
- * gc where the end of this segment is and where the next
- * segment of this type resides. Allocation occurs from the
- * beginning of the newly obtained segment. The need for the
- * eos marker explains the (2 * ptr_bytes) byte factor in
- * S_find_more_room.
- */
-/* S_find_more_room is always called with mutex */
-ptr S_find_more_room(ISPC s, IGEN g, iptr n, ptr old) {
- iptr nsegs, seg;
- ptr new;
-
- S_pants_down += 1;
-
- nsegs = (uptr)(n + 2 * ptr_bytes + bytes_per_segment - 1) >> segment_offset_bits;
-
- /* block requests to minimize fragmentation and improve cache locality */
- if (s == space_code && nsegs < 16) nsegs = 16;
-
- seg = S_find_segments(s, g, nsegs);
- new = build_ptr(seg, 0);
-
- if (old == FIX(0)) {
- /* first object of this space */
- S_G.first_loc[g][s] = new;
- } else {
- uptr bytes = (char *)old - (char *)S_G.base_loc[g][s];
- /* increment bytes_allocated by the closed-off partial segment */
- S_G.bytes_of_space[g][s] += bytes;
- S_G.bytes_of_generation[g] += bytes;
- /* lay down an end-of-segment marker */
- *(ptr*)old = forward_marker;
- *((ptr*)old + 1) = new;
- }
-
- /* base address of current block of segments to track amount of allocation */
- S_G.base_loc[g][s] = new;
-
- S_G.next_loc[g][s] = (ptr)((uptr)new + n);
- S_G.bytes_left[g][s] = (nsegs * bytes_per_segment - n) - 2 * ptr_bytes;
-
- if (g == 0 && S_pants_down == 1) maybe_fire_collector();
-
- S_pants_down -= 1;
- return new;
-}
-
-/* S_reset_allocation_pointer is always called with mutex */
-/* We always allocate exactly one segment for the allocation area, since
- we can get into hot water with formerly locked objects, specifically
- symbols and impure records, that cross segment boundaries. This allows
- us to maintain the invariant that no object crosses a segment boundary
- unless it starts on a segment boundary (and is thus at least one
- segment long). NB. This invariant does not apply to code objects
- since we grab large blocks of segments for them.
-*/
-
-void S_reset_allocation_pointer(ptr tc) {
- iptr seg;
-
- S_pants_down += 1;
-
- seg = S_find_segments(space_new, 0, 1);
-
- /* NB: if allocate_segments didn't already ensure we don't use the last segment
- of memory, we'd have to reject it here so cp2-alloc can avoid a carry check for
- small allocation requests, using something like this:
-
- if (seg == (((uptr)1 << (ptr_bits - segment_offset_bits)) - 1))
- seg = S_find_segments(space_new, 0, 1);
- */
-
- S_G.bytes_of_space[0][space_new] += bytes_per_segment;
- S_G.bytes_of_generation[0] += bytes_per_segment;
-
- if (S_pants_down == 1) maybe_fire_collector();
-
- AP(tc) = build_ptr(seg, 0);
- REAL_EAP(tc) = EAP(tc) = (ptr)((uptr)AP(tc) + bytes_per_segment);
-
- S_pants_down -= 1;
-}
-
-
-FORCEINLINE void mark_segment_dirty(seginfo *si, IGEN from_g, IGEN to_g) {
- IGEN old_to_g = si->min_dirty_byte;
- if (to_g < old_to_g) {
- seginfo **pointer_to_first, *oldfirst;
- if (old_to_g != 0xff) {
- seginfo *next = si->dirty_next, **prev = si->dirty_prev;
- /* presently on some other list, so remove */
- *prev = next;
- if (next != NULL) next->dirty_prev = prev;
- }
- oldfirst = *(pointer_to_first = &DirtySegments(from_g, to_g));
- *pointer_to_first = si;
- si->dirty_prev = pointer_to_first;
- si->dirty_next = oldfirst;
- if (oldfirst != NULL) oldfirst->dirty_prev = &si->dirty_next;
- si->min_dirty_byte = to_g;
- }
-}
-
-void S_dirty_set(ptr *loc, ptr x) {
- *loc = x;
- if (!Sfixnump(x)) {
- seginfo *si = SegInfo(addr_get_segment(loc));
- IGEN from_g = si->generation;
- if (from_g != 0) {
- si->dirty_bytes[((uptr)loc >> card_offset_bits) & ((1 << segment_card_offset_bits) - 1)] = 0;
- mark_segment_dirty(si, from_g, 0);
- }
- }
-}
-
-void S_mark_card_dirty(uptr card, IGEN to_g) {
- uptr loc = card << card_offset_bits;
- uptr seg = addr_get_segment(loc);
- seginfo *si = SegInfo(seg);
- uptr cardno = card & ((1 << segment_card_offset_bits) - 1);
- if (to_g < si->dirty_bytes[cardno]) {
- si->dirty_bytes[cardno] = to_g;
- mark_segment_dirty(si, si->generation, to_g);
- }
-}
-
-/* scan remembered set from P to ENDP, transferring to dirty vector */
-void S_scan_dirty(ptr **p, ptr **endp) {
- uptr this, last;
-
- last = 0;
-
- while (p < endp) {
- ptr *loc = *p;
- /* whether building s directory or running UXLB code, the most
- common situations are that *loc is a fixnum, this == last, or loc
- is in generation 0. the generated code no longer adds elements
- to the remembered set if the RHS val is a fixnum. the other
- checks we do here. we don't bother looking for *loc being an
- immediate or outside the heap, nor for the generation of *loc
- being the same or older than the generation of loc, since these
- don't seem to weed out many dirty writes, and we don't want to
- waste time here on fruitless memory reads and comparisions */
- if ((this = (uptr)loc >> card_offset_bits) != last) {
- seginfo *si = SegInfo(addr_get_segment(loc));
- IGEN from_g = si->generation;
- if (from_g != 0) {
- si->dirty_bytes[((uptr)loc >> card_offset_bits) & ((1 << segment_card_offset_bits) - 1)] = 0;
- if (this >> segment_card_offset_bits != last >> segment_card_offset_bits) mark_segment_dirty(si, from_g, 0);
- }
- last = this;
- }
- p += 1;
- }
-}
-
-/* S_scan_remembered_set is called from generated machine code when there
- * is insufficient room for a remembered set addition.
- */
-
-void S_scan_remembered_set(void) {
- ptr tc = get_thread_context();
- uptr ap, eap, real_eap;
-
- tc_mutex_acquire()
-
- ap = (uptr)AP(tc);
- eap = (uptr)EAP(tc);
- real_eap = (uptr)REAL_EAP(tc);
-
- S_scan_dirty((ptr **)eap, (ptr **)real_eap);
- eap = real_eap;
-
- if (eap - ap > alloc_waste_maximum) {
- AP(tc) = (ptr)ap;
- EAP(tc) = (ptr)eap;
- } else {
- uptr bytes = eap - ap;
- S_G.bytes_of_space[0][space_new] -= bytes;
- S_G.bytes_of_generation[0] -= bytes;
- S_reset_allocation_pointer(tc);
- }
-
- tc_mutex_release()
-}
-
-/* S_get_more_room is called from generated machine code when there is
- * insufficient room for an allocation. ap has already been incremented
- * by the size of the object and xp is a (typed) pointer to the value of
- * ap before the allocation attempt. xp must be set to a new object of
- * the appropriate type and size.
- */
-
-void S_get_more_room(void) {
- ptr tc = get_thread_context();
- ptr xp; uptr ap, type, size;
-
- xp = XP(tc);
- if ((type = TYPEBITS(xp)) == 0) type = typemod;
- ap = (uptr)UNTYPE(xp, type);
- size = (uptr)((iptr)AP(tc) - (iptr)ap);
-
- XP(tc) = S_get_more_room_help(tc, ap, type, size);
-}
-
-ptr S_get_more_room_help(ptr tc, uptr ap, uptr type, uptr size) {
- ptr x; uptr eap, real_eap;
-
- eap = (uptr)EAP(tc);
- real_eap = (uptr)REAL_EAP(tc);
-
- tc_mutex_acquire()
-
- S_scan_dirty((ptr **)eap, (ptr **)real_eap);
- eap = real_eap;
-
- if (eap - ap >= size) {
- x = TYPE(ap, type);
- ap += size;
- if (eap - ap > alloc_waste_maximum) {
- AP(tc) = (ptr)ap;
- EAP(tc) = (ptr)eap;
- } else {
- uptr bytes = eap - ap;
- S_G.bytes_of_space[0][space_new] -= bytes;
- S_G.bytes_of_generation[0] -= bytes;
- S_reset_allocation_pointer(tc);
- }
- } else if (eap - ap > alloc_waste_maximum) {
- AP(tc) = (ptr)ap;
- EAP(tc) = (ptr)eap;
- find_room(space_new, 0, type, size, x);
- } else {
- uptr bytes = eap - ap;
- S_G.bytes_of_space[0][space_new] -= bytes;
- S_G.bytes_of_generation[0] -= bytes;
- S_reset_allocation_pointer(tc);
- ap = (uptr)AP(tc);
- if (size + alloc_waste_maximum <= (uptr)EAP(tc) - ap) {
- x = TYPE(ap, type);
- AP(tc) = (ptr)(ap + size);
- } else {
- find_room(space_new, 0, type, size, x);
- }
- }
-
- tc_mutex_release()
-
- return x;
-}
-
-/* S_cons_in is always called with mutex */
-ptr S_cons_in(ISPC s, IGEN g, ptr car, ptr cdr) {
- ptr p;
-
- find_room(s, g, type_pair, size_pair, p);
- INITCAR(p) = car;
- INITCDR(p) = cdr;
- return p;
-}
-
-ptr Scons(ptr car, ptr cdr) {
- ptr tc = get_thread_context();
- ptr p;
-
- thread_find_room(tc, type_pair, size_pair, p);
- INITCAR(p) = car;
- INITCDR(p) = cdr;
- return p;
-}
-
-ptr Sbox(ptr ref) {
- ptr tc = get_thread_context();
- ptr p;
-
- thread_find_room(tc, type_typed_object, size_box, p);
- BOXTYPE(p) = type_box;
- INITBOXREF(p) = ref;
- return p;
-}
-
-ptr S_symbol(ptr name) {
- ptr tc = get_thread_context();
- ptr p;
-
- thread_find_room(tc, type_symbol, size_symbol, p);
- /* changes here should be reflected in the oblist collection code in gc.c */
- INITSYMVAL(p) = sunbound;
- INITSYMCODE(p,S_G.nonprocedure_code);
- INITSYMPLIST(p) = snil;
- INITSYMSPLIST(p) = snil;
- INITSYMNAME(p) = name;
- INITSYMHASH(p) = Sfalse;
- return p;
-}
-
-ptr S_rational(ptr n, ptr d) {
- if (d == FIX(1)) return n;
- else {
- ptr tc = get_thread_context();
- ptr p;
-
- thread_find_room(tc, type_typed_object, size_ratnum, p);
- RATTYPE(p) = type_ratnum;
- RATNUM(p) = n;
- RATDEN(p) = d;
- return p;
- }
-}
-
-ptr S_tlc(ptr keyval, ptr ht, ptr next) {
- ptr tc = get_thread_context();
- ptr p;
-
- thread_find_room(tc, type_typed_object, size_tlc, p);
- TLCTYPE(p) = type_tlc;
- INITTLCKEYVAL(p) = keyval;
- INITTLCHT(p) = ht;
- INITTLCNEXT(p) = next;
- return p;
-}
-
-/* S_vector_in is always called with mutex */
-ptr S_vector_in(ISPC s, IGEN g, iptr n) {
- ptr p; iptr d;
-
- if (n == 0) return S_G.null_vector;
-
- if ((uptr)n >= maximum_vector_length)
- S_error("", "invalid vector size request");
-
- d = size_vector(n);
- /* S_vector_in always called with mutex */
- find_room(s, g, type_typed_object, d, p);
- VECTTYPE(p) = (n << vector_length_offset) | type_vector;
- return p;
-}
-
-ptr S_vector(iptr n) {
- ptr tc;
- ptr p; iptr d;
-
- if (n == 0) return S_G.null_vector;
-
- if ((uptr)n >= maximum_vector_length)
- S_error("", "invalid vector size request");
-
- tc = get_thread_context();
-
- d = size_vector(n);
- thread_find_room(tc, type_typed_object, d, p);
- VECTTYPE(p) = (n << vector_length_offset) | type_vector;
- return p;
-}
-
-ptr S_fxvector(iptr n) {
- ptr tc;
- ptr p; iptr d;
-
- if (n == 0) return S_G.null_fxvector;
-
- if ((uptr)n > (uptr)maximum_fxvector_length)
- S_error("", "invalid fxvector size request");
-
- tc = get_thread_context();
-
- d = size_fxvector(n);
- thread_find_room(tc, type_typed_object, d, p);
- FXVECTOR_TYPE(p) = (n << fxvector_length_offset) | type_fxvector;
- return p;
-}
-
-ptr S_bytevector(iptr n) {
- ptr tc;
- ptr p; iptr d;
-
- if (n == 0) return S_G.null_bytevector;
-
- if ((uptr)n > (uptr)maximum_bytevector_length)
- S_error("", "invalid bytevector size request");
-
- tc = get_thread_context();
-
- d = size_bytevector(n);
- thread_find_room(tc, type_typed_object, d, p);
- BYTEVECTOR_TYPE(p) = (n << bytevector_length_offset) | type_bytevector;
- return p;
-}
-
-ptr S_null_immutable_vector(void) {
- ptr v;
- find_room(space_new, 0, type_typed_object, size_vector(0), v);
- VECTTYPE(v) = (0 << vector_length_offset) | type_vector | vector_immutable_flag;
- return v;
-}
-
-ptr S_null_immutable_fxvector(void) {
- ptr v;
- find_room(space_new, 0, type_typed_object, size_fxvector(0), v);
- VECTTYPE(v) = (0 << fxvector_length_offset) | type_fxvector | fxvector_immutable_flag;
- return v;
-}
-
-ptr S_null_immutable_bytevector(void) {
- ptr v;
- find_room(space_new, 0, type_typed_object, size_bytevector(0), v);
- VECTTYPE(v) = (0 << bytevector_length_offset) | type_bytevector | bytevector_immutable_flag;
- return v;
-}
-
-ptr S_null_immutable_string(void) {
- ptr v;
- find_room(space_new, 0, type_typed_object, size_string(0), v);
- VECTTYPE(v) = (0 << string_length_offset) | type_string | string_immutable_flag;
- return v;
-}
-
-ptr S_record(iptr n) {
- ptr tc = get_thread_context();
- ptr p;
-
- thread_find_room(tc, type_typed_object, n, p);
- return p;
-}
-
-ptr S_closure(ptr cod, iptr n) {
- ptr tc = get_thread_context();
- ptr p; iptr d;
-
- d = size_closure(n);
- thread_find_room(tc, type_closure, d, p);
- CLOSENTRY(p) = cod;
- return p;
-}
-
-/* S_mkcontinuation is always called with mutex */
-ptr S_mkcontinuation(ISPC s, IGEN g, ptr nuate, ptr stack, iptr length, iptr clength,
- ptr link, ptr ret, ptr winders) {
- ptr p;
-
- find_room(s, g, type_closure, size_continuation, p);
- CLOSENTRY(p) = nuate;
- CONTSTACK(p) = stack;
- CONTLENGTH(p) = length;
- CONTCLENGTH(p) = clength;
- CONTLINK(p) = link;
- CONTRET(p) = ret;
- CONTWINDERS(p) = winders;
- return p;
-}
-
-ptr Sflonum(double x) {
- ptr tc = get_thread_context();
- ptr p;
-
- thread_find_room(tc, type_flonum, size_flonum, p);
- FLODAT(p) = x;
- return p;
-}
-
-ptr S_inexactnum(double rp, double ip) {
- ptr tc = get_thread_context();
- ptr p;
-
- thread_find_room(tc, type_typed_object, size_inexactnum, p);
- INEXACTNUM_TYPE(p) = type_inexactnum;
- INEXACTNUM_REAL_PART(p) = rp;
- INEXACTNUM_IMAG_PART(p) = ip;
- return p;
-}
-
-/* S_thread is always called with mutex */
-ptr S_thread(ptr xtc) {
- ptr p;
-
- /* don't use thread_find_room since we may be building the current thread */
- find_room(space_new, 0, type_typed_object, size_thread, p);
- TYPEFIELD(p) = (ptr)type_thread;
- THREADTC(p) = (uptr)xtc;
- return p;
-}
-
-ptr S_exactnum(ptr a, ptr b) {
- ptr tc = get_thread_context();
- ptr p;
-
- thread_find_room(tc, type_typed_object, size_exactnum, p);
- EXACTNUM_TYPE(p) = type_exactnum;
- EXACTNUM_REAL_PART(p) = a;
- EXACTNUM_IMAG_PART(p) = b;
- return p;
-}
-
-/* S_string returns a new string of length n. If s is not NULL, it is
- * copied into the new string. If n < 0, then s must be non-NULL,
- * and the length of s (by strlen) determines the length of the string */
-ptr S_string(const char *s, iptr n) {
- ptr tc;
- ptr p; iptr d;
- iptr i;
-
- if (n < 0) n = strlen(s);
-
- if (n == 0) return S_G.null_string;
-
- if ((uptr)n > (uptr)maximum_string_length)
- S_error("", "invalid string size request");
-
- tc = get_thread_context();
-
- d = size_string(n);
- thread_find_room(tc, type_typed_object, d, p);
- STRTYPE(p) = (n << string_length_offset) | type_string;
-
- /* fill the string with valid characters */
- i = 0;
-
- /* first copy input string, if any */
- if (s != (char *)NULL) {
- while (i != n && *s != 0) {
- Sstring_set(p, i, *s++);
- i += 1;
- }
- }
-
- /* fill remaining slots with nul */
- while (i != n) {
- Sstring_set(p, i, 0);
- i += 1;
- }
-
- return p;
-}
-
-ptr Sstring_utf8(const char *s, iptr n) {
- const char* u8;
- iptr cc, d, i, n8;
- ptr p, tc;
-
- if (n < 0) n = strlen(s);
-
- if (n == 0) return S_G.null_string;
-
- /* determine code point count cc */
- u8 = s;
- n8 = n;
- cc = 0;
- while (n8 > 0) {
- unsigned char b1 = *(const unsigned char*)u8++;
- n8--;
- cc++;
- if ((b1 & 0x80) == 0)
- ;
- else if ((b1 & 0x40) == 0)
- ;
- else if ((b1 & 0x20) == 0) {
- if ((n8 >= 1) && ((*u8 & 0xc0) == 0x80)) {
- u8++;
- n8--;
- }
- } else if ((b1 & 0x10) == 0) {
- if ((n8 >= 1) && ((*u8 & 0xc0) == 0x80)) {
- u8++;
- n8--;
- if ((n8 >= 1) && ((*u8 & 0xc0) == 0x80)) {
- u8++;
- n8--;
- }
- }
- } else if ((b1 & 0x08) == 0) {
- if ((n8 >= 1) && ((*u8 & 0xc0) == 0x80)) {
- u8++;
- n8--;
- if ((n8 >= 1) && ((*u8 & 0xc0) == 0x80)) {
- u8++;
- n8--;
- if ((n8 >= 1) && ((*u8 & 0xc0) == 0x80)) {
- u8++;
- n8--;
- }
- }
- }
- }
- }
-
- if ((uptr)cc > (uptr)maximum_string_length)
- S_error("", "invalid string size request");
-
- tc = get_thread_context();
- d = size_string(cc);
- thread_find_room(tc, type_typed_object, d, p);
- STRTYPE(p) = (cc << string_length_offset) | type_string;
-
- /* fill the string */
- u8 = s;
- n8 = n;
- i = 0;
- while (n8 > 0) {
- unsigned char b1 = *u8++;
- int c = 0xfffd;
- n8--;
- if ((b1 & 0x80) == 0)
- c = b1;
- else if ((b1 & 0x40) == 0)
- ;
- else if ((b1 & 0x20) == 0) {
- unsigned char b2;
- if ((n8 >= 1) && (((b2 = *u8) & 0xc0) == 0x80)) {
- int x = ((b1 & 0x1f) << 6) | (b2 & 0x3f);
- u8++;
- n8--;
- if (x >= 0x80)
- c = x;
- }
- } else if ((b1 & 0x10) == 0) {
- unsigned char b2;
- if ((n8 >= 1) && (((b2 = *u8) & 0xc0) == 0x80)) {
- unsigned char b3;
- u8++;
- n8--;
- if ((n8 >= 1) && (((b3 = *u8) & 0xc0) == 0x80)) {
- int x = ((b1 & 0x0f) << 12) | ((b2 & 0x3f) << 6) | (b3 & 0x3f);
- u8++;
- n8--;
- if ((x >= 0x800) && ((x < 0xd800) || (x > 0xdfff)))
- c = x;
- }
- }
- } else if ((b1 & 0x08) == 0) {
- unsigned char b2;
- if ((n8 >= 1) && (((b2 = *u8) & 0xc0) == 0x80)) {
- unsigned char b3;
- u8++;
- n8--;
- if ((n8 >= 1) && (((b3 = *u8) & 0xc0) == 0x80)) {
- unsigned char b4;
- u8++;
- n8--;
- if ((n8 >= 1) && (((b4 = *u8) & 0xc0) == 0x80)) {
- int x = ((b1 & 0x07) << 18) | ((b2 & 0x3f) << 12) | ((b3 & 0x3f) << 6) | (b4 & 0x3f);
- u8++;
- n8--;
- if ((x >= 0x10000) && (x <= 0x10ffff))
- c = x;
- }
- }
- }
- }
- Sstring_set(p, i++, c);
- }
- return p;
-}
-
-ptr S_bignum(ptr tc, iptr n, IBOOL sign) {
- ptr p; iptr d;
-
- if ((uptr)n > (uptr)maximum_bignum_length)
- S_error("", "invalid bignum size request");
-
- d = size_bignum(n);
- thread_find_room(tc, type_typed_object, d, p);
- BIGTYPE(p) = (uptr)n << bignum_length_offset | sign << bignum_sign_offset | type_bignum;
- return p;
-}
-
-/* S_code is always called with mutex */
-ptr S_code(ptr tc, iptr type, iptr n) {
- ptr p; iptr d;
-
- d = size_code(n);
- find_room(space_code, 0, type_typed_object, d, p);
- CODETYPE(p) = type;
- CODELEN(p) = n;
- /* we record the code modification here, even though we haven't
- even started modifying the code yet, since we always create
- and fill the code object within a critical section. */
- S_record_code_mod(tc, (uptr)&CODEIT(p,0), (uptr)n);
- return p;
-}
-
-ptr S_relocation_table(iptr n) {
- ptr tc = get_thread_context();
- ptr p; iptr d;
-
- d = size_reloc_table(n);
- thread_find_room(tc, typemod, d, p);
- RELOCSIZE(p) = n;
- return p;
-}
-
-ptr S_weak_cons(ptr car, ptr cdr) {
- ptr p;
- tc_mutex_acquire();
- p = S_cons_in(space_weakpair, 0, car, cdr);
- tc_mutex_release();
- return p;
-}
diff --git a/ta6ob/c/alloc.o b/ta6ob/c/alloc.o
deleted file mode 100644
index 1219037..0000000
Binary files a/ta6ob/c/alloc.o and /dev/null differ
diff --git a/ta6ob/c/compress-io.c b/ta6ob/c/compress-io.c
deleted file mode 100644
index 6333648..0000000
--- a/ta6ob/c/compress-io.c
+++ /dev/null
@@ -1,672 +0,0 @@
-/* compress-io.c
- * Copyright 1984-2019 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.
- */
-
-/* Dispatch to zlib or LZ4 */
-
-#include "system.h"
-#include "zlib.h"
-#include "lz4.h"
-#include "lz4frame.h"
-#include "lz4hc.h"
-#include
-#include
-
-#ifdef WIN32
-#include
-# define WIN32_IZE(id) _ ## id
-# define GLZ_O_BINARY O_BINARY
-#else
-# define WIN32_IZE(id) id
-# define GLZ_O_BINARY 0
-#endif
-
-/* the value of LZ4_OUTPUT_PORT_IN_BUFFER_SIZE was determined
- through experimentation on an intel linux server and an intel
- osx laptop. smaller sizes result in significantly worse compression
- of object files, and larger sizes don't have much beneficial effect.
- don't increase the output-port in-buffer size unless you're sure
- it reduces object-file size or reduces compression time
- significantly. don't decrease it unless you're sure it doesn't
- increase object-file size significantly. one buffer of size
- LZ4_OUTPUT_PORT_IN_BUFFER_SIZE is allocated per lz4-compressed
- output port. another buffer of a closely related size is allocated
- per thread. */
-#define LZ4_OUTPUT_PORT_IN_BUFFER_SIZE (1 << 18)
-
-/* the values we choose for LZ4_INPUT_PORT_IN_BUFFER_SIZE and
- LZ4_INPUT_PORT_OUT_BUFFER_SIZE don't seem to make much difference
- in decompression speed, so we keep them fairly small. one buffer
- of size LZ4_INPUT_PORT_IN_BUFFER_SIZE and one buffer of size
- LZ4_INPUT_PORT_OUT_BUFFER_SIZE are allocated per lz4-compressed
- input port. */
-#define LZ4_INPUT_PORT_IN_BUFFER_SIZE (1 << 12)
-#define LZ4_INPUT_PORT_OUT_BUFFER_SIZE (1 << 14)
-
-typedef struct lz4File_out_r {
- LZ4F_preferences_t preferences;
- INT fd;
- INT out_buffer_size;
- INT in_pos;
- INT err;
- size_t stream_pos;
- char in_buffer[LZ4_OUTPUT_PORT_IN_BUFFER_SIZE];
-} lz4File_out;
-
-typedef struct lz4File_in_r {
- INT fd;
- LZ4F_dctx *dctx;
- INT in_pos, in_len, out_pos, out_len;
- INT frame_ended;
- INT err;
- size_t stream_pos;
- off_t init_pos;
- char in_buffer[LZ4_INPUT_PORT_IN_BUFFER_SIZE];
- char out_buffer[LZ4_INPUT_PORT_OUT_BUFFER_SIZE];
-} lz4File_in;
-
-typedef struct sized_buffer_r {
- INT size;
- char buffer[0];
-} sized_buffer;
-
-/* local functions */
-static glzFile glzdopen_output_gz(INT fd, INT compress_level);
-static glzFile glzdopen_output_lz4(INT fd, INT compress_level);
-static glzFile glzdopen_input_gz(INT fd);
-static glzFile glzdopen_input_lz4(INT fd, off_t init_pos);
-static INT glzread_lz4(lz4File_in *lz4, void *buffer, UINT count);
-static INT glzemit_lz4(lz4File_out *lz4, void *buffer, UINT count);
-static INT glzwrite_lz4(lz4File_out *lz4, void *buffer, UINT count);
-
-INT S_zlib_compress_level(INT compress_level) {
- switch (compress_level) {
- case COMPRESS_MIN:
- case COMPRESS_LOW:
- return Z_BEST_SPEED;
- case COMPRESS_MEDIUM:
- return (Z_BEST_SPEED + Z_BEST_COMPRESSION) / 2;
- case COMPRESS_HIGH:
- return (Z_BEST_SPEED + (3 * Z_BEST_COMPRESSION)) / 4;
- case COMPRESS_MAX:
- return Z_BEST_COMPRESSION;
- default:
- S_error1("S_zlib_compress_level", "unexpected compress level ~s", Sinteger(compress_level));
- return 0;
- }
-}
-
-static glzFile glzdopen_output_gz(INT fd, INT compress_level) {
- gzFile gz;
- glzFile glz;
- INT as_append;
- INT level;
-
-#ifdef WIN32
- as_append = 0;
-#else
- as_append = fcntl(fd, F_GETFL) & O_APPEND;
-#endif
-
- if ((gz = gzdopen(fd, as_append ? "ab" : "wb")) == Z_NULL) return Z_NULL;
-
- level = S_zlib_compress_level(compress_level);
-
- gzsetparams(gz, level, Z_DEFAULT_STRATEGY);
-
- if ((glz = malloc(sizeof(struct glzFile_r))) == NULL) {
- (void)gzclose(gz);
- return Z_NULL;
- }
- glz->fd = fd;
- glz->inputp = 0;
- glz->format = COMPRESS_GZIP;
- glz->gz = gz;
- return glz;
-}
-
-INT S_lz4_compress_level(INT compress_level) {
- switch (compress_level) {
- case COMPRESS_MIN:
- case COMPRESS_LOW:
- return 1;
- case COMPRESS_MEDIUM:
- return LZ4HC_CLEVEL_MIN;
- case COMPRESS_HIGH:
- return (LZ4HC_CLEVEL_MIN + LZ4HC_CLEVEL_MAX) / 2;
- case COMPRESS_MAX:
- return LZ4HC_CLEVEL_MAX;
- default:
- S_error1("S_lz4_compress_level", "unexpected compress level ~s", Sinteger(compress_level));
- return 0;
- }
-}
-
-static glzFile glzdopen_output_lz4(INT fd, INT compress_level) {
- glzFile glz;
- lz4File_out *lz4;
- INT level;
-
- level = S_lz4_compress_level(compress_level);
-
- if ((lz4 = malloc(sizeof(lz4File_out))) == NULL) return Z_NULL;
- memset(&lz4->preferences, 0, sizeof(LZ4F_preferences_t));
- lz4->preferences.compressionLevel = level;
- lz4->fd = fd;
- lz4->out_buffer_size = (INT)LZ4F_compressFrameBound(LZ4_OUTPUT_PORT_IN_BUFFER_SIZE, &lz4->preferences);
- lz4->in_pos = 0;
- lz4->err = 0;
- lz4->stream_pos = 0;
-
- if ((glz = malloc(sizeof(struct glzFile_r))) == NULL) {
- free(lz4);
- return Z_NULL;
- }
- glz->fd = fd;
- glz->inputp = 0;
- glz->format = COMPRESS_LZ4;
- glz->lz4_out = lz4;
- return glz;
-}
-
-glzFile S_glzdopen_output(INT fd, INT compress_format, INT compress_level) {
- switch (compress_format) {
- case COMPRESS_GZIP:
- return glzdopen_output_gz(fd, compress_level);
- case COMPRESS_LZ4:
- return glzdopen_output_lz4(fd, compress_level);
- default:
- S_error1("glzdopen_output", "unexpected compress format ~s", Sinteger(compress_format));
- return Z_NULL;
- }
-}
-
-static glzFile glzdopen_input_gz(INT fd) {
- gzFile gz;
- glzFile glz;
-
- if ((gz = gzdopen(fd, "rb")) == Z_NULL) return Z_NULL;
-
- if ((glz = malloc(sizeof(struct glzFile_r))) == NULL) {
- (void)gzclose(gz);
- return Z_NULL;
- }
- glz->fd = fd;
- glz->inputp = 1;
- glz->format = COMPRESS_GZIP;
- glz->gz = gz;
- return glz;
-}
-
-static glzFile glzdopen_input_lz4(INT fd, off_t init_pos) {
- glzFile glz;
- LZ4F_dctx *dctx;
- LZ4F_errorCode_t r;
- lz4File_in *lz4;
-
- r = LZ4F_createDecompressionContext(&dctx, LZ4F_VERSION);
- if (LZ4F_isError(r))
- return Z_NULL;
-
- if ((lz4 = malloc(sizeof(lz4File_in))) == NULL) {
- (void)LZ4F_freeDecompressionContext(dctx);
- return Z_NULL;
- }
- lz4->fd = fd;
- lz4->dctx = dctx;
- lz4->in_pos = 0;
- lz4->in_len = 0;
- lz4->out_len = 0;
- lz4->out_pos = 0;
- lz4->frame_ended = 0;
- lz4->err = 0;
- lz4->stream_pos = 0;
- lz4->init_pos = init_pos;
-
- if ((glz = malloc(sizeof(struct glzFile_r))) == NULL) {
- (void)LZ4F_freeDecompressionContext(lz4->dctx);
- free(lz4);
- return Z_NULL;
- }
- glz->fd = fd;
- glz->inputp = 1;
- glz->format = COMPRESS_LZ4;
- glz->lz4_in = lz4;
- return glz;
-}
-
-glzFile S_glzdopen_input(INT fd) {
- INT r, pos = 0;
- unsigned char buffer[4];
- off_t init_pos;
-
- /* check for LZ4 magic number, otherwise defer to gzdopen */
-
- if ((init_pos = WIN32_IZE(lseek)(fd, 0, SEEK_CUR)) == -1) return Z_NULL;
-
- while (pos < 4) {
- r = WIN32_IZE(read)(fd, (char*)buffer + pos, 4 - pos);
- if (r == 0)
- break;
- else if (r > 0)
- pos += r;
-#ifdef EINTR
- else if (errno == EINTR)
- continue;
-#endif
- else
- break; /* error reading */
- }
-
- if (pos > 0) {
- if (WIN32_IZE(lseek)(fd, init_pos, SEEK_SET) == -1) return Z_NULL;
- }
-
- if ((pos == 4)
- && (buffer[0] == 0x04)
- && (buffer[1] == 0x22)
- && (buffer[2] == 0x4d)
- && (buffer[3] == 0x18))
- return glzdopen_input_lz4(fd, init_pos);
-
- return glzdopen_input_gz(fd);
-}
-
-glzFile S_glzopen_input(const char *path) {
- INT fd;
-
- fd = WIN32_IZE(open)(path, O_RDONLY | GLZ_O_BINARY);
-
- if (fd == -1)
- return Z_NULL;
- else
- return S_glzdopen_input(fd);
-}
-
-#ifdef WIN32
-glzFile S_glzopen_input_w(const wchar_t *path) {
- INT fd;
-
- fd = _wopen(path, O_RDONLY | GLZ_O_BINARY);
-
- if (fd == -1)
- return Z_NULL;
- else
- return S_glzdopen_input(fd);
-}
-#endif
-
-IBOOL S_glzdirect(glzFile glz) {
- if (glz->format == COMPRESS_GZIP)
- return gzdirect(glz->gz);
- else
- return 0;
-}
-
-INT S_glzclose(glzFile glz) {
- INT r = Z_OK, saved_errno = 0;
- switch (glz->format) {
- case COMPRESS_GZIP:
- r = gzclose(glz->gz);
- break;
- case COMPRESS_LZ4:
- if (glz->inputp) {
- lz4File_in *lz4 = glz->lz4_in;
- while (1) {
- INT r = WIN32_IZE(close)(lz4->fd);
-#ifdef EINTR
- if (r < 0 && errno == EINTR) continue;
-#endif
- if (r == 0) { saved_errno = errno; }
- break;
- }
- (void)LZ4F_freeDecompressionContext(lz4->dctx);
- free(lz4);
- } else {
- lz4File_out *lz4 = glz->lz4_out;
- if (lz4->in_pos != 0) {
- r = glzemit_lz4(lz4, lz4->in_buffer, lz4->in_pos);
- if (r >= 0) r = Z_OK; else { r = Z_ERRNO; saved_errno = errno; }
- }
- while (1) {
- int r1 = WIN32_IZE(close)(lz4->fd);
-#ifdef EINTR
- if (r1 < 0 && errno == EINTR) continue;
-#endif
- if (r == Z_OK && r1 < 0) { r = Z_ERRNO; saved_errno = errno; }
- break;
- }
- free(lz4);
- }
- break;
- default:
- S_error1("S_glzclose", "unexpected compress format ~s", Sinteger(glz->format));
- }
- free(glz);
- if (saved_errno) errno = saved_errno;
- return r;
-}
-
-static INT glzread_lz4(lz4File_in *lz4, void *buffer, UINT count) {
- while (lz4->out_pos == lz4->out_len) {
- INT in_avail;
-
- in_avail = lz4->in_len - lz4->in_pos;
- if (!in_avail) {
- while (1) {
- in_avail = WIN32_IZE(read)(lz4->fd, lz4->in_buffer, LZ4_INPUT_PORT_IN_BUFFER_SIZE);
- if (in_avail >= 0) {
- lz4->in_len = in_avail;
- lz4->in_pos = 0;
- break;
-#ifdef EINTR
- } else if (errno == EINTR) {
- /* try again */
-#endif
- } else {
- lz4->err = Z_ERRNO;
- return -1;
- }
- }
- }
-
- if (in_avail > 0) {
- size_t amt, out_len = LZ4_INPUT_PORT_OUT_BUFFER_SIZE, in_len = in_avail;
-
- /* For a large enough result buffer, try to decompress directly
- to that buffer: */
- if (count >= (out_len >> 1)) {
- size_t direct_out_len = count;
-
- if (lz4->frame_ended && lz4->in_buffer[lz4->in_pos] == 0)
- return 0; /* count 0 after frame as stream terminator */
-
- amt = LZ4F_decompress(lz4->dctx,
- buffer, &direct_out_len,
- lz4->in_buffer + lz4->in_pos, &in_len,
- NULL);
- lz4->frame_ended = (amt == 0);
-
- if (LZ4F_isError(amt)) {
- lz4->err = Z_STREAM_ERROR;
- return -1;
- }
-
- lz4->in_pos += (INT)in_len;
-
- if (direct_out_len) {
- lz4->stream_pos += direct_out_len;
- return (INT)direct_out_len;
- }
-
- in_len = in_avail - in_len;
- }
-
- if (in_len > 0) {
- if (lz4->frame_ended && lz4->in_buffer[lz4->in_pos] == 0)
- return 0; /* count 0 after frame as stream terminator */
-
- amt = LZ4F_decompress(lz4->dctx,
- lz4->out_buffer, &out_len,
- lz4->in_buffer + lz4->in_pos, &in_len,
- NULL);
- lz4->frame_ended = (amt == 0);
-
- if (LZ4F_isError(amt)) {
- lz4->err = Z_STREAM_ERROR;
- return -1;
- }
-
- lz4->in_pos += (INT)in_len;
- lz4->out_len = (INT)out_len;
- lz4->out_pos = 0;
- }
- } else {
- /* EOF on read */
- break;
- }
- }
-
- if (lz4->out_pos < lz4->out_len) {
- UINT amt = lz4->out_len - lz4->out_pos;
- if (amt > count) amt = count;
- memcpy(buffer, lz4->out_buffer + lz4->out_pos, amt);
- lz4->out_pos += amt;
- lz4->stream_pos += amt;
- return amt;
- }
-
- return 0;
-}
-
-INT S_glzread(glzFile glz, void *buffer, UINT count) {
- switch (glz->format) {
- case COMPRESS_GZIP:
- return gzread(glz->gz, buffer, count);
- case COMPRESS_LZ4:
- return glzread_lz4(glz->lz4_in, buffer, count);
- default:
- S_error1("S_glzread", "unexpected compress format ~s", Sinteger(glz->format));
- return -1;
- }
-}
-
-static INT glzemit_lz4(lz4File_out *lz4, void *buffer, UINT count) {
- ptr tc = get_thread_context();
- sized_buffer *cached_out_buffer;
- char *out_buffer;
- INT out_len, out_pos;
- INT r = 0;
-
- /* allocate one out_buffer (per thread) since we don't need one for each file.
- the buffer is freed by destroy_thread. */
- if ((cached_out_buffer = LZ4OUTBUFFER(tc)) == NULL || cached_out_buffer->size < lz4->out_buffer_size) {
- if (cached_out_buffer != NULL) free(cached_out_buffer);
- if ((LZ4OUTBUFFER(tc) = cached_out_buffer = malloc(sizeof(sized_buffer) + lz4->out_buffer_size)) == NULL) return -1;
- cached_out_buffer->size = lz4->out_buffer_size;
- }
- out_buffer = cached_out_buffer->buffer;
-
- out_len = (INT)LZ4F_compressFrame(out_buffer, lz4->out_buffer_size,
- buffer, count,
- &lz4->preferences);
- if (LZ4F_isError(out_len)) {
- lz4->err = Z_STREAM_ERROR;
- return -1;
- }
-
- out_pos = 0;
- while (out_pos < out_len) {
- r = WIN32_IZE(write)(lz4->fd, out_buffer + out_pos, out_len - out_pos);
- if (r >= 0)
- out_pos += r;
-#ifdef EINTR
- else if (errno == EINTR)
- continue;
-#endif
- else
- break;
- }
-
- return r;
-}
-
-static INT glzwrite_lz4(lz4File_out *lz4, void *buffer, UINT count) {
- UINT amt; INT r;
-
- if ((amt = LZ4_OUTPUT_PORT_IN_BUFFER_SIZE - lz4->in_pos) > count) amt = count;
-
- if (amt == LZ4_OUTPUT_PORT_IN_BUFFER_SIZE) {
- /* full buffer coming from input...skip the memcpy */
- if ((r = glzemit_lz4(lz4, buffer, LZ4_OUTPUT_PORT_IN_BUFFER_SIZE)) < 0) return 0;
- } else {
- memcpy(lz4->in_buffer + lz4->in_pos, buffer, amt);
- if ((lz4->in_pos += amt) == LZ4_OUTPUT_PORT_IN_BUFFER_SIZE) {
- lz4->in_pos = 0;
- if ((r = glzemit_lz4(lz4, lz4->in_buffer, LZ4_OUTPUT_PORT_IN_BUFFER_SIZE)) < 0) return 0;
- }
- }
-
- lz4->stream_pos += amt;
- return amt;
-}
-
-INT S_glzwrite(glzFile glz, void *buffer, UINT count) {
- switch (glz->format) {
- case COMPRESS_GZIP:
- return gzwrite(glz->gz, buffer, count);
- case COMPRESS_LZ4:
- return glzwrite_lz4(glz->lz4_out, buffer, count);
- default:
- S_error1("S_glzwrite", "unexpected compress format ~s", Sinteger(glz->format));
- return -1;
- }
-}
-
-long S_glzseek(glzFile glz, long offset, INT whence) {
- switch (glz->format) {
- case COMPRESS_GZIP:
- return gzseek(glz->gz, offset, whence);
- case COMPRESS_LZ4:
- if (glz->inputp) {
- lz4File_in *lz4 = glz->lz4_in;
- if (whence == SEEK_CUR)
- offset += (long)lz4->stream_pos;
- if (offset < 0)
- offset = 0;
- if ((size_t)offset < lz4->stream_pos) {
- /* rewind and read from start */
- if (WIN32_IZE(lseek)(lz4->fd, lz4->init_pos, SEEK_SET) < 0) {
- lz4->err = Z_ERRNO;
- return -1;
- }
- LZ4F_resetDecompressionContext(lz4->dctx);
- lz4->in_pos = 0;
- lz4->in_len = 0;
- lz4->out_len = 0;
- lz4->out_pos = 0;
- lz4->err = 0;
- lz4->stream_pos = 0;
- }
- while ((size_t)offset > lz4->stream_pos) {
- static char buffer[1024];
- size_t amt = (size_t)offset - lz4->stream_pos;
- if (amt > sizeof(buffer)) amt = sizeof(buffer);
- if (glzread_lz4(lz4, buffer, (UINT)amt) < 0)
- return -1;
- }
- return (long)lz4->stream_pos;
- } else {
- lz4File_out *lz4 = glz->lz4_out;
- if (whence == SEEK_CUR)
- offset += (long)lz4->stream_pos;
- if (offset >= 0) {
- while ((size_t)offset > lz4->stream_pos) {
- size_t amt = (size_t)offset - lz4->stream_pos;
- if (amt > 8) amt = 8;
- if (glzwrite_lz4(lz4, "\0\0\0\0\0\0\0\0", (UINT)amt) < 0)
- return -1;
- }
- }
- return (long)lz4->stream_pos;
- }
- default:
- S_error1("S_glzseek", "unexpected compress format ~s", Sinteger(glz->format));
- return -1;
- }
-}
-
-INT S_glzgetc(glzFile glz) {
- switch (glz->format) {
- case COMPRESS_GZIP:
- return gzgetc(glz->gz);
- case COMPRESS_LZ4:
- {
- unsigned char buffer[1];
- INT r;
- r = S_glzread(glz, buffer, 1);
- if (r == 1)
- return buffer[0];
- else
- return -1;
- }
- default:
- S_error1("S_glzgetc", "unexpected compress format ~s", Sinteger(glz->format));
- return -1;
- }
-}
-
-INT S_glzungetc(INT c, glzFile glz) {
- switch (glz->format) {
- case COMPRESS_GZIP:
- return gzungetc(c, glz->gz);
- case COMPRESS_LZ4:
- {
- lz4File_in *lz4 = glz->lz4_in;
- if (lz4->out_len == 0)
- lz4->out_len = lz4->out_pos = 1;
- if (lz4->out_pos) {
- lz4->out_pos--;
- lz4->out_buffer[lz4->out_pos] = c;
- lz4->stream_pos--;
- return c;
- } else {
- /* support ungetc only just after a getc, in which case there
- should have been room */
- return -1;
- }
- }
- default:
- S_error1("S_glzungetc", "unexpected compress format ~s", Sinteger(glz->format));
- return -1;
- }
-}
-
-INT S_glzrewind(glzFile glz) {
- return S_glzseek(glz, 0, SEEK_SET);
-}
-
-void S_glzerror(glzFile glz, INT *errnum) {
- switch (glz->format) {
- case COMPRESS_GZIP:
- (void)gzerror(glz->gz, errnum);
- break;
- case COMPRESS_LZ4:
- if (glz->inputp)
- *errnum = glz->lz4_in->err;
- else
- *errnum = glz->lz4_out->err;
- break;
- default:
- S_error1("S_glzerror", "unexpected compress format ~s", Sinteger(glz->format));
- *errnum = 0;
- }
-}
-
-void S_glzclearerr(glzFile glz) {
- switch (glz->format) {
- case COMPRESS_GZIP:
- gzclearerr(glz->gz);
- break;
- case COMPRESS_LZ4:
- if (glz->inputp)
- glz->lz4_in->err = 0;
- else
- glz->lz4_out->err = 0;
- break;
- default:
- S_error1("S_glzerror", "unexpected compress format ~s", Sinteger(glz->format));
- }
-}
diff --git a/ta6ob/c/compress-io.h b/ta6ob/c/compress-io.h
deleted file mode 100644
index a5f988b..0000000
--- a/ta6ob/c/compress-io.h
+++ /dev/null
@@ -1,26 +0,0 @@
-/* compress-io.h
- * Copyright 1984-2019 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.
- */
-
-typedef struct glzFile_r {
- INT fd;
- IBOOL inputp;
- INT format;
- union {
- struct gzFile_s *gz;
- struct lz4File_in_r *lz4_in;
- struct lz4File_out_r *lz4_out;
- };
-} *glzFile;
diff --git a/ta6ob/c/compress-io.o b/ta6ob/c/compress-io.o
deleted file mode 100644
index 7487efe..0000000
Binary files a/ta6ob/c/compress-io.o and /dev/null differ
diff --git a/ta6ob/c/config.h b/ta6ob/c/config.h
deleted file mode 100644
index 2817b36..0000000
--- a/ta6ob/c/config.h
+++ /dev/null
@@ -1,4 +0,0 @@
-#define SCHEME_SCRIPT "scheme-script"
-#ifndef WIN32
-#define DEFAULT_HEAP_PATH "/usr/local/lib/csv%v/%m"
-#endif
diff --git a/ta6ob/c/expeditor.c b/ta6ob/c/expeditor.c
deleted file mode 100644
index c148e96..0000000
--- a/ta6ob/c/expeditor.c
+++ /dev/null
@@ -1,1087 +0,0 @@
-/* expeditor.c
- * Copyright 1984-2017 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.
- */
-
-#include "system.h"
-
-#ifdef FEATURE_EXPEDITOR
-
-/* locally defined functions */
-static IBOOL s_ee_init_term(void);
-static ptr s_ee_read_char(IBOOL blockp);
-static void s_ee_write_char(wchar_t c);
-static void s_ee_flush(void);
-static ptr s_ee_get_screen_size(void);
-static void s_ee_raw(void);
-static void s_ee_noraw(void);
-static void s_ee_enter_am_mode(void);
-static void s_ee_exit_am_mode(void);
-static void s_ee_pause(void);
-static void s_ee_nanosleep(U32 secs, U32 nanosecs);
-static ptr s_ee_get_clipboard(void);
-static void s_ee_up(I32);
-static void s_ee_down(I32);
-static void s_ee_left(I32);
-static void s_ee_right(I32);
-static void s_ee_clear_eol(void);
-static void s_ee_clear_eos(void);
-static void s_ee_clear_screen(void);
-static void s_ee_scroll_reverse(I32);
-static void s_ee_bell(void);
-static void s_ee_carriage_return(void);
-static void s_ee_line_feed(void);
-
-static INT init_status = -1;
-
-#ifdef WIN32
-
-#include
-#include
-
-static HANDLE hStdout, hStdin;
-static DWORD InMode, OutMode;
-
-static IBOOL s_ee_init_term(void) {
- CONSOLE_SCREEN_BUFFER_INFO csbiInfo;
-
- if (init_status != -1) return init_status;
-
- init_status =
- (hStdin = GetStdHandle(STD_INPUT_HANDLE)) != INVALID_HANDLE_VALUE
- && (hStdout = GetStdHandle(STD_OUTPUT_HANDLE)) != INVALID_HANDLE_VALUE
- && GetConsoleScreenBufferInfo(hStdout, &csbiInfo)
- && GetConsoleMode(hStdin, &InMode)
- && GetConsoleMode(hStdout, &OutMode);
-
- return init_status;
-}
-
-/* returns char, eof, #t (winched), or #f (nothing ready), the latter
- only if blockp is false */
-static ptr s_ee_read_char(IBOOL blockp) {
- DWORD cNumRead;
- INPUT_RECORD irInBuf[1];
-#ifdef PTHREADS
- ptr tc;
-#endif /* PTHREADS */
- BOOL succ;
- static wchar_t buf[10];
- static int bufidx = 0;
- static int buflen = 0;
- static int rptcnt = 0;
-
- for (;;) {
- if (buflen != 0) {
- int i = bufidx++;
- if (bufidx == buflen) {
- bufidx = 0;
- if (--rptcnt == 0) buflen = 0;
- }
- return Schar(buf[i]);
- }
-
- if (!blockp) {
- DWORD NumberOfEvents;
- if (!GetNumberOfConsoleInputEvents(hStdin, &NumberOfEvents))
- S_error1("expeditor", "error getting console input: ~a",
- S_LastErrorString());
- if (NumberOfEvents == 0) return Sfalse;
- }
-
-#ifdef PTHREADS
- tc = get_thread_context();
- if (DISABLECOUNT(tc) == FIX(0)) {
- deactivate_thread(tc);
- succ = ReadConsoleInputW(hStdin, irInBuf, 1, &cNumRead);
- reactivate_thread(tc);
- } else {
- succ = ReadConsoleInputW(hStdin, irInBuf, 1, &cNumRead);
- }
-#else /* PTHREADS */
- succ = ReadConsoleInputW(hStdin, irInBuf, 1, &cNumRead);
-#endif /* PTHREADS */
-
-
- if (!succ)
- S_error1("expeditor", "error getting console info: ~a",
- S_LastErrorString());
-
- if (cNumRead == 0) return Seof_object;
-
- switch(irInBuf[0].EventType) {
- case KEY_EVENT: {
- KEY_EVENT_RECORD ker = irInBuf[0].Event.KeyEvent;
- rptcnt = ker.wRepeatCount;
- if (ker.bKeyDown) {
- wchar_t c;
-
- if (c = ker.uChar.UnicodeChar) {
- /* translate ^ to nul */
- if (c == 0x20 && (ker.dwControlKeyState & (LEFT_CTRL_PRESSED|RIGHT_CTRL_PRESSED)))
- buf[0] = 0;
- else
- buf[0] = c;
- buflen = 1;
- } else {
- switch (ker.wVirtualKeyCode) {
- case VK_DELETE:
- buf[0] = '\033';
- buf[1] = '[';
- buf[2] = '3';
- buf[3] = '~';
- buflen = 4;
- break;
- case VK_NEXT: /* page-down */
- buf[0] = '\033';
- buf[1] = '[';
- buf[2] = '6';
- buf[3] = '~';
- buflen = 4;
- break;
- case VK_PRIOR: /* page-up */
- buf[0] = '\033';
- buf[1] = '[';
- buf[2] = '5';
- buf[3] = '~';
- buflen = 4;
- break;
- case VK_END:
- buf[0] = '\033';
- buf[1] = '[';
- buf[2] = 'F';
- buflen = 3;
- break;
- case VK_HOME:
- buf[0] = '\033';
- buf[1] = '[';
- buf[2] = 'H';
- buflen = 3;
- break;
- case VK_LEFT:
- buf[0] = '\033';
- buf[1] = '[';
- buf[2] = 'D';
- buflen = 3;
- break;
- case VK_UP:
- buf[0] = '\033';
- buf[1] = '[';
- buf[2] = 'A';
- buflen = 3;
- break;
- case VK_RIGHT:
- buf[0] = '\033';
- buf[1] = '[';
- buf[2] = 'C';
- buflen = 3;
- break;
- case VK_DOWN:
- buf[0] = '\033';
- buf[1] = '[';
- buf[2] = 'B';
- buflen = 3;
- break;
- /* translate ^@ to nul */
- case 0x32:
- if (ker.dwControlKeyState & (LEFT_CTRL_PRESSED|RIGHT_CTRL_PRESSED)) {
- buf[0] = 0;
- buflen = 1;
- }
- break;
- default:
- break;
- }
- }
- }
- break;
- }
-
- /* this tells us when the buffer size changes, but nothing comes through
- when the window size changes. */
- case WINDOW_BUFFER_SIZE_EVENT: // scrn buf. resizing
- return Strue;
-
- default:
- break;
- }
- }
-}
-
-/* probably need write-char too */
-
-static ptr s_ee_get_screen_size(void) {
- CONSOLE_SCREEN_BUFFER_INFO csbiInfo;
-
- if (!GetConsoleScreenBufferInfo(hStdout, &csbiInfo))
- S_error1("expeditor", "error getting console info: ~a",
- S_LastErrorString());
-
- return Scons(Sinteger(csbiInfo.srWindow.Bottom - csbiInfo.srWindow.Top + 1),
- Sinteger(csbiInfo.srWindow.Right - csbiInfo.srWindow.Left + 1));
-}
-
-static void s_ee_raw(void) {
- /* see http://msdn2.microsoft.com/en-us/library/ms686033.aspx */
- if (!SetConsoleMode(hStdin, ENABLE_WINDOW_INPUT)
- || !SetConsoleMode(hStdout, 0))
- S_error1("expeditor", "error setting console mode: ~a",
- S_LastErrorString());
-}
-
-static void s_ee_noraw(void) {
- if (!SetConsoleMode(hStdin, InMode) || !SetConsoleMode(hStdout, OutMode))
- S_error1("expeditor", "error setting console mode: ~a",
- S_LastErrorString());
-}
-
-static void s_ee_enter_am_mode(void) { return; }
-
-static void s_ee_exit_am_mode(void) { return; }
-
-static void s_ee_pause(void) { return; }
-
-static void s_ee_nanosleep(U32 secs, U32 nanosecs) {
- Sleep((secs * 1000) + (nanosecs / 1000000));
-}
-
-static void s_ee_up(I32 n) {
- CONSOLE_SCREEN_BUFFER_INFO csbiInfo;
- COORD cursor_pos;
-
- fflush(stdout);
-
- if (!GetConsoleScreenBufferInfo(hStdout, &csbiInfo))
- S_error1("expeditor", "error getting console info: ~a",
- S_LastErrorString());
-
- cursor_pos.X = csbiInfo.dwCursorPosition.X;
- cursor_pos.Y = csbiInfo.dwCursorPosition.Y - n;
-
- /* ignore error, which can occur only if someone else screwed with screen */
- SetConsoleCursorPosition(hStdout, cursor_pos);
-}
-
-static void s_ee_down(I32 n) {
- CONSOLE_SCREEN_BUFFER_INFO csbiInfo;
- COORD cursor_pos;
-
- fflush(stdout);
-
- if (!GetConsoleScreenBufferInfo(hStdout, &csbiInfo))
- S_error1("expeditor", "error getting console info: ~a",
- S_LastErrorString());
-
- cursor_pos.X = csbiInfo.dwCursorPosition.X;
- cursor_pos.Y = csbiInfo.dwCursorPosition.Y + n;
-
- /* ignore error, which can occur only if someone else screwed with screen */
- SetConsoleCursorPosition(hStdout, cursor_pos);
-}
-
-static void s_ee_left(I32 n) {
- CONSOLE_SCREEN_BUFFER_INFO csbiInfo;
- COORD cursor_pos;
-
- fflush(stdout);
-
- if (!GetConsoleScreenBufferInfo(hStdout, &csbiInfo))
- S_error1("expeditor", "error getting console info: ~a",
- S_LastErrorString());
-
- cursor_pos.X = csbiInfo.dwCursorPosition.X - n;
- cursor_pos.Y = csbiInfo.dwCursorPosition.Y;
-
- /* ignore error, which can occur only if someone else screwed with screen */
- SetConsoleCursorPosition(hStdout, cursor_pos);
-}
-
-static void s_ee_right(I32 n) {
- CONSOLE_SCREEN_BUFFER_INFO csbiInfo;
- COORD cursor_pos;
-
- fflush(stdout);
-
- if (!GetConsoleScreenBufferInfo(hStdout, &csbiInfo))
- S_error1("expeditor", "error getting console info: ~a",
- S_LastErrorString());
-
- cursor_pos.X = csbiInfo.dwCursorPosition.X + n;
- cursor_pos.Y = csbiInfo.dwCursorPosition.Y;
-
- /* ignore error, which can occur only if someone else screwed with screen */
- SetConsoleCursorPosition(hStdout, cursor_pos);
-}
-
-static void s_ee_clear_eol(void) {
- CONSOLE_SCREEN_BUFFER_INFO csbiInfo;
- DWORD ntowrite, numwritten;
-
- fflush(stdout);
-
- if (!GetConsoleScreenBufferInfo(hStdout, &csbiInfo))
- S_error1("expeditor", "error getting console info: ~a",
- S_LastErrorString());
-
- ntowrite = csbiInfo.dwSize.X - csbiInfo.dwCursorPosition.X;
-
- if (!FillConsoleOutputCharacter(hStdout, (TCHAR)' ',
- ntowrite, csbiInfo.dwCursorPosition, &numwritten))
- S_error1("expeditor", "error clearing section of screen buffer: ~a",
- S_LastErrorString());
-
- if (!FillConsoleOutputAttribute(hStdout, csbiInfo.wAttributes,
- ntowrite, csbiInfo.dwCursorPosition, &numwritten))
- S_error1("expeditor", "error setting attributes in section of screen buffer: ~a",
- S_LastErrorString());
-}
-
-static void s_ee_clear_eos(void) {
- CONSOLE_SCREEN_BUFFER_INFO csbiInfo;
- DWORD ntowrite, numwritten;
-
- fflush(stdout);
-
- if (!GetConsoleScreenBufferInfo(hStdout, &csbiInfo))
- S_error1("expeditor", "error getting console info: ~a",
- S_LastErrorString());
-
- ntowrite = (csbiInfo.dwSize.X - csbiInfo.dwCursorPosition.X) +
- (csbiInfo.dwSize.X *
- (csbiInfo.dwSize.Y - csbiInfo.dwCursorPosition.Y - 1));
-
- if (!FillConsoleOutputCharacter(hStdout, (TCHAR)' ',
- ntowrite, csbiInfo.dwCursorPosition, &numwritten))
- S_error1("expeditor", "error clearing section of screen buffer: ~a",
- S_LastErrorString());
-
- if (!FillConsoleOutputAttribute(hStdout, csbiInfo.wAttributes,
- ntowrite, csbiInfo.dwCursorPosition, &numwritten))
- S_error1("expeditor", "error setting attributes in section of screen buffer: ~a",
- S_LastErrorString());
-}
-
-static void s_ee_clear_screen(void) {
- CONSOLE_SCREEN_BUFFER_INFO csbiInfo;
- COORD cursor_pos;
- DWORD ntowrite, numwritten;
-
- fflush(stdout);
-
- if (!GetConsoleScreenBufferInfo(hStdout, &csbiInfo))
- S_error1("expeditor", "error getting console info: ~a",
- S_LastErrorString());
-
- cursor_pos.X = 0;
- cursor_pos.Y = csbiInfo.srWindow.Top;
- SetConsoleCursorPosition(hStdout, cursor_pos);
-
- ntowrite = csbiInfo.dwSize.X * (csbiInfo.dwSize.Y - cursor_pos.Y);
-
- if (!FillConsoleOutputCharacter(hStdout, (TCHAR)' ',
- ntowrite, cursor_pos, &numwritten))
- S_error1("expeditor", "error clearing section of screen buffer: ~a",
- S_LastErrorString());
-
- if (!FillConsoleOutputAttribute(hStdout, csbiInfo.wAttributes,
- ntowrite, cursor_pos, &numwritten))
- S_error1("expeditor", "error setting attributes in section of screen buffer: ~a",
- S_LastErrorString());
-}
-
-static void s_ee_scroll_reverse(I32 n) {
- CONSOLE_SCREEN_BUFFER_INFO csbiInfo;
-
- fflush(stdout);
-
- if (!GetConsoleScreenBufferInfo(hStdout, &csbiInfo))
- S_error1("expeditor", "error getting console info: ~a",
- S_LastErrorString());
-
- if (csbiInfo.dwCursorPosition.Y - n < 0) {
- SMALL_RECT rect;
- COORD dest;
- CHAR_INFO fill;
-
- /* set fill to blank so new top lines will be cleared */
- fill.Attributes = csbiInfo.wAttributes;
- fill.Char.AsciiChar = (char)' ';
-
- /* move lines 0 through N-n-1 down to lines n through N-1 */
- rect.Top = 0;
- rect.Bottom = csbiInfo.dwSize.Y - n - 1;
- rect.Left = 0;
- rect.Right = csbiInfo.dwSize.X - 1;
- dest.X = 0;
- dest.Y = n;
- if (!ScrollConsoleScreenBuffer(hStdout, &rect, (SMALL_RECT *)0, dest, &fill))
- S_error1("expeditor", "error scrolling screen buffer: ~a",
- S_LastErrorString());
- } else {
- COORD cursor_pos; DWORD numwritten;
-
- cursor_pos.X = csbiInfo.dwCursorPosition.X;
- cursor_pos.Y = csbiInfo.dwCursorPosition.Y - n;
- SetConsoleCursorPosition(hStdout, cursor_pos);
-
- if (!FillConsoleOutputCharacter(hStdout, (TCHAR)' ',
- csbiInfo.dwSize.X * n, cursor_pos, &numwritten))
- S_error1("expeditor", "error clearing section of screen buffer: ~a",
- S_LastErrorString());
-
- if (!FillConsoleOutputAttribute(hStdout, csbiInfo.wAttributes,
- csbiInfo.dwSize.X * n, cursor_pos, &numwritten))
- S_error1("expeditor", "error setting attributes in section of screen buffer: ~a",
- S_LastErrorString());
- }
-}
-
-static void s_ee_bell(void) {
- MessageBeep(MB_OK);
-}
-
-static void s_ee_carriage_return(void) {
- CONSOLE_SCREEN_BUFFER_INFO csbiInfo;
- COORD cursor_pos;
-
- fflush(stdout);
-
- if (!GetConsoleScreenBufferInfo(hStdout, &csbiInfo))
- S_error1("expeditor", "error getting console info: ~a",
- S_LastErrorString());
-
- cursor_pos.X = 0;
- cursor_pos.Y = csbiInfo.dwCursorPosition.Y;
-
- SetConsoleCursorPosition(hStdout, cursor_pos);
-}
-
-static void s_ee_line_feed(void) {
- CONSOLE_SCREEN_BUFFER_INFO csbiInfo;
-
- fflush(stdout);
-
- if (!GetConsoleScreenBufferInfo(hStdout, &csbiInfo))
- S_error1("expeditor", "error getting console info: ~a",
- S_LastErrorString());
-
- if (csbiInfo.dwCursorPosition.Y == (csbiInfo.dwSize.Y - 1)) {
- SMALL_RECT rect;
- COORD dest;
- CHAR_INFO fill;
-
- /* set fill to blank so new bottom line will be cleared */
- fill.Attributes = csbiInfo.wAttributes;
- fill.Char.AsciiChar = (char)' ';
-
- /* move lines 1 through N-1 up to lines 0 through N-2 */
- rect.Top = 1;
- rect.Bottom = csbiInfo.dwSize.Y - 1;
- rect.Left = 0;
- rect.Right = csbiInfo.dwSize.X - 1;
- dest.X = 0;
- dest.Y = 0;
- if (!ScrollConsoleScreenBuffer(hStdout, &rect, (SMALL_RECT *)0, dest, &fill))
- S_error1("expeditor", "error scrolling screen buffer: ~a",
- S_LastErrorString());
- } else {
- COORD cursor_pos;
-
- cursor_pos.X = csbiInfo.dwCursorPosition.X;
- cursor_pos.Y = csbiInfo.dwCursorPosition.Y + 1;
- SetConsoleCursorPosition(hStdout, cursor_pos);
- }
-}
-
-static ptr s_ee_get_clipboard(void) {
- ptr x = S_G.null_string;
-
- if (OpenClipboard((HWND)0)) {
- HANDLE h = GetClipboardData(CF_UNICODETEXT);
- if (h != NULL) {
- wchar_t *w = (wchar_t*)GlobalLock(h);
- if (w != NULL) {
- char *s = Swide_to_utf8(w);
- x = Sstring_utf8(s, -1);
- free(s);
- GlobalUnlock(h);
- }
- }
- CloseClipboard();
- }
-
- return x;
-}
-
-static void s_ee_write_char(wchar_t c) {
- DWORD n;
- WriteConsoleW(hStdout, &c, 1, &n, NULL);
-}
-
-#else /* WIN32 */
-#include
-#ifdef DISABLE_CURSES
-#include "nocurses.h"
-#elif defined(SOLARIS)
-#define NCURSES_CONST
-#define CHTYPE int
-#include
-#include
-#elif defined(NETBSD)
-#include
-#include
-#else /* NETBSD */
-#include
-#include
-#endif /* SOLARIS */
-#include
-#include
-#include
-#include
-#include
-#include
-#if !defined(__linux__) && !defined(__OpenBSD__) && !defined(__NetBSD__)
-#include
-#endif
-
-#if defined(TIOCGWINSZ) && defined(SIGWINCH) && defined(EINTR)
-#define HANDLE_SIGWINCH
-#endif
-
-#ifdef USE_MBRTOWC_L
-static locale_t the_locale;
-static locale_t uselocale_alt(locale_t l) {
- locale_t old = the_locale;
- the_locale = l;
- return old;
-}
-# define uselocale(v) uselocale_alt(v)
-# define mbrtowc(pwc, s, n, ps) mbrtowc_l(pwc, s, n, ps, the_locale)
-#endif
-
-/* locally defined functions */
-static int eeputc(tputsputcchar c);
-#ifdef HANDLE_SIGWINCH
-static void handle_sigwinch(int sig);
-#endif
-
-#ifdef HANDLE_SIGWINCH
-static IBOOL winched = 0;
-static void handle_sigwinch(UNUSED int sig) {
- winched = 1;
-}
-#endif
-
-#define STDIN_FD 0
-#define STDOUT_FD 1
-
-static IBOOL disable_auto_margin = 0, avoid_last_column = 0;
-static locale_t term_locale;
-static mbstate_t term_in_mbs;
-static mbstate_t term_out_mbs;
-
-static IBOOL s_ee_init_term(void) {
- int errret;
-
- if (init_status != -1) return init_status;
-
- if (isatty(STDIN_FD)
- && isatty(STDOUT_FD)
- && setupterm(NULL, STDOUT_FD, &errret) != ERR
-/* assuming here and in our optproc definitions later that the names of
- missing capabilities are set to NULL, although this does not appear
- to be documented */
- && cursor_up
- && cursor_down
- && cursor_left
- && cursor_right
- && clr_eol
- && clr_eos
- && clear_screen
- && scroll_reverse
- && carriage_return) {
- if (auto_right_margin) {
- /* terminal automatically wraps. safest to disable if possible */
- if (exit_am_mode && enter_am_mode) {
- disable_auto_margin = 1;
- avoid_last_column = 0;
- /* can't disable automatic margins, but eat_newline_glitch is set.
- may still be okay, since we never write past the last column,
- and the automatic newline should be emitted only if we do. but
- see hack in s_ee_enter_am_mode */
- } else if (eat_newline_glitch) {
- disable_auto_margin = 0;
- avoid_last_column = 0;
- } else {
- disable_auto_margin = 0;
- avoid_last_column = 1;
- }
- } else {
- disable_auto_margin = 0;
- avoid_last_column = 0;
- }
-
-#ifdef HANDLE_SIGWINCH
- struct sigaction act;
-
- sigemptyset(&act.sa_mask);
-
- act.sa_flags = 0;
- act.sa_handler = handle_sigwinch;
- sigaction(SIGWINCH, &act, (struct sigaction *)0);
-#endif
-
- term_locale = newlocale(LC_ALL_MASK, "", NULL);
- memset(&term_out_mbs, 0, sizeof(term_out_mbs));
- memset(&term_in_mbs, 0, sizeof(term_in_mbs));
-
- init_status = 1;
- } else {
- init_status = 0;
- }
-
- return init_status;
-}
-
-/* returns char, eof, #t (winched), or #f (nothing ready), the latter
- only if blockp is false */
-static ptr s_ee_read_char(IBOOL blockp) {
- ptr msg; int fd = STDIN_FD; int n; char buf[1]; wchar_t wch; size_t sz;
- locale_t old_locale;
-#ifdef PTHREADS
- ptr tc = get_thread_context();
-#endif
-
- do {
-#ifdef HANDLE_SIGWINCH
- if (winched) { winched = 0; return Strue; }
-#endif
-#ifdef PTHREADS
- if (!blockp || DISABLECOUNT(tc) == FIX(0)) {
- fcntl(fd, F_SETFL, fcntl(fd, F_GETFL, 0) | NOBLOCK);
- n = READ(fd, buf, 1);
- fcntl(fd, F_SETFL, fcntl(fd, F_GETFL, 0) & ~NOBLOCK);
- if (n < 0 && errno == EWOULDBLOCK) {
- if (!blockp) return Sfalse;
- deactivate_thread(tc);
- n = READ(fd, buf, 1);
- reactivate_thread(tc);
- }
- } else {
- n = READ(fd, buf, 1);
- }
-#else /* PTHREADS */
- if (!blockp) {
- fcntl(fd, F_SETFL, fcntl(fd, F_GETFL, 0) | NOBLOCK);
- n = READ(fd, buf, 1);
- fcntl(fd, F_SETFL, fcntl(fd, F_GETFL, 0) & ~NOBLOCK);
- if (n < 0 && errno == EWOULDBLOCK) return Sfalse;
- } else {
- n = READ(fd, buf, 1);
- }
-#endif /* PTHREADS */
-
- if (n == 1) {
- if (buf[0] == '\0') {
- return Schar('\0');
- } else {
- old_locale = uselocale(term_locale);
- sz = mbrtowc(&wch, buf, 1, &term_out_mbs);
- uselocale(old_locale);
- if (sz == 1) {
- return Schar(wch);
- }
- }
- }
-
- } while ((n < 0 && errno == EINTR) || (n == 1 && sz == (size_t)-2));
-
- if (n == 0) return Seof_object;
-
- msg = S_strerror(errno);
- S_error1("expeditor", "error reading from console: ~a", msg);
-
- memset(&term_out_mbs, 0, sizeof(term_out_mbs));
- return Svoid;
-}
-
-/* returns a pair of positive integers */
-static ptr s_ee_get_screen_size(void) {
- static INT ee_rows = 0;
- static INT ee_cols = 0;
-
-#ifdef TIOCGWINSZ
- struct winsize ws;
- if (ioctl(STDOUT_FD, TIOCGWINSZ, &ws) == 0) {
- if (ws.ws_row > 0) ee_rows = ws.ws_row;
- if (ws.ws_col > 0) ee_cols = ws.ws_col;
- }
-#ifdef MACOSX
- static IBOOL tried_resize = 0;
- /* attempt to work around 10.6 tty driver / xterm bug */
- if (ee_rows == 0 && ee_cols == 0 && !tried_resize) {
- system("exec /usr/X11/bin/resize >& /dev/null");
- tried_resize = 1;
- return s_ee_get_screen_size();
- }
-#endif /* MACOSX */
-#endif /* TIOCGWINSZ */
-
- if (ee_rows == 0) {
- char *s, *endp;
- if ((s = getenv("LINES")) != NULL) {
- INT n = (int)strtol(s, &endp, 10);
- if (n > 0 && *endp == '\0') ee_rows = n;
- }
- if (ee_rows == 0) ee_rows = lines > 0 ? lines : 24;
- }
-
- if (ee_cols == 0) {
- char *s, *endp;
- if ((s = getenv("COLUMNS")) != NULL) {
- INT n = (int)strtol(s, &endp, 10);
- if (n > 0 && *endp == '\0') ee_cols = n;
- }
- if (ee_cols == 0) ee_cols = columns > 0 ? columns : 80;
- }
-
- return Scons(Sinteger(ee_rows), Sinteger(ee_cols > 1 && avoid_last_column ? ee_cols - 1 : ee_cols));
-}
-
-static int eeputc(tputsputcchar c) {
- return putchar(c);
-}
-
-static struct termios orig_termios;
-
-static void s_ee_raw(void) {
- struct termios new_termios;
- while (tcgetattr(STDIN_FD, &orig_termios) != 0) {
- if (errno != EINTR) {
- ptr msg = S_strerror(errno);
- if (msg != Sfalse)
- S_error1("expeditor", "error entering raw mode: ~a", msg);
- else
- S_error("expeditor", "error entering raw mode");
- }
- }
- new_termios = orig_termios;
-
- /* essentially want "stty raw -echo". the appropriate flags to accomplish
- this were determined by studying the gnu/linux stty and termios man
- pages, with particular attention to the cfmakeraw function. */
- new_termios.c_iflag &= ~(IGNBRK|BRKINT|PARMRK|INPCK|ISTRIP
- |INLCR|IGNCR|ICRNL|IXON);
- new_termios.c_oflag &= ~(OPOST);
- new_termios.c_lflag &= ~(ISIG|ICANON|ECHO|IEXTEN);
- new_termios.c_cflag &= ~(CSIZE|PARENB);
- new_termios.c_cflag |= CS8;
- new_termios.c_cc[VMIN] = 1;
- new_termios.c_cc[VTIME] = 0;
-
- while (tcsetattr(STDIN_FD, TCSADRAIN, &new_termios) != 0) {
- if (errno != EINTR) {
- ptr msg = S_strerror(errno);
- if (msg != Sfalse)
- S_error1("expeditor", "error entering raw mode: ~a", msg);
- else
- S_error("expeditor", "error entering raw mode");
- }
- }
-}
-
-static void s_ee_noraw(void) {
- while (tcsetattr(STDIN_FD, TCSADRAIN, &orig_termios) != 0) {
- if (errno != EINTR) {
- ptr msg = S_strerror(errno);
- if (msg != Sfalse)
- S_error1("expeditor", "error leaving raw mode: ~a", msg);
- else
- S_error("expeditor", "error leaving raw mode");
- }
- }
-}
-
-static void s_ee_enter_am_mode(void) {
- if (disable_auto_margin) {
- tputs(enter_am_mode, 1, eeputc);
- /* flush to minimize time span when automatic margins are disabled */
- fflush(stdout);
- } else if (eat_newline_glitch) {
- /* hack: try to prevent terminal from eating subsequent cr or lf.
- assumes we've just written to last column. probably works only
- for vt100 interpretation of eat_newline_glitch/xn/xenl flag. */
- tputs(cursor_left, 1, eeputc);
- tputs(cursor_right, 1, eeputc);
- }
-}
-
-static void s_ee_exit_am_mode(void) {
- if (disable_auto_margin) {
- tputs(exit_am_mode, 1, eeputc);
- }
-}
-
-static void s_ee_pause(void) { /* used to handle ^Z */
- fflush(stdout);
- kill(0, SIGTSTP);
-}
-
-static void s_ee_nanosleep(U32 secs, U32 nanosecs) {
- struct timespec ts;
- ts.tv_sec = secs;
- ts.tv_nsec = nanosecs;
- nanosleep(&ts, (struct timespec *)0);
-}
-
-static void s_ee_up(I32 n) {
- while (n--) tputs(cursor_up, 1, eeputc);
-}
-
-static void s_ee_down(I32 n) {
- while (n--) tputs(cursor_down, 1, eeputc);
-}
-
-static void s_ee_left(I32 n) {
- while (n--) tputs(cursor_left, 1, eeputc);
-}
-
-static void s_ee_right(I32 n) {
- while (n--) tputs(cursor_right, 1, eeputc);
-}
-
-static void s_ee_clear_eol(void) {
- tputs(clr_eol, 1, eeputc);
-}
-
-static void s_ee_clear_eos(void) {
- tputs(clr_eos, 1, eeputc);
-}
-
-static void s_ee_clear_screen(void) {
- tputs(clear_screen, 1, eeputc);
-}
-
-static void s_ee_scroll_reverse(I32 n) {
- /* moving up from an entry that was only partially displayed,
- scroll-reverse may be called when cursor isn't at the top line of
- the screen, in which case we hope it will move up by one line.
- in this case, which we have no way of distinguishing from the normal
- case, scroll-reverse needs to clear the line explicitly */
- while (n--) {
- tputs(scroll_reverse, 1, eeputc);
- tputs(clr_eol, 1, eeputc);
- }
-}
-
-static void s_ee_bell(void) {
- tputs(bell, 1, eeputc);
-}
-
-static void s_ee_carriage_return(void) {
- tputs(carriage_return, 1, eeputc);
-}
-
-/* move-line-down doesn't scroll the screen when performed on the last
- line on the freebsd and openbsd consoles. the official way to scroll
- the screen is to use scroll-forward (ind), but ind is defined only
- at the bottom left corner of the screen, and we don't always know
- where the bottom of the screen actually is. so we write a line-feed
- (newline) character and hope that will do the job. */
-static void s_ee_line_feed(void) {
- putchar(0x0a);
-}
-
-#ifdef LIBX11
-#include
-#include
-#include
-#include
-#endif /* LIBX11 */
-
-static ptr s_ee_get_clipboard(void) {
-#ifdef LIBX11
- static enum {UNINITIALIZED, INITIALIZED, FAILED} status = UNINITIALIZED;
- static int (*pXConvertSelection)(Display *, Atom, Atom, Atom, Window, Time);
- static int (*pXPending)(Display *display);
- static int (*pXNextEvent)(Display *, XEvent *);
- static int (*pXGetWindowProperty)(Display *, Window, Atom, long, long, Bool, Atom, Atom *, int *, unsigned long *, unsigned long *, unsigned char **);
- static int (*pXFree)(void *);
-
- static Display *D;
- static Window R, W;
-#endif /* LIBX11 */
-
- ptr p = S_G.null_string;
-
-#ifdef LIBX11
- if (status == UNINITIALIZED) {
- char *display_name;
- void *handle;
- Display *(*pXOpenDisplay)(char *);
- Window (*pXDefaultRootWindow)(Display *);
- Window (*pXCreateSimpleWindow)(Display *, Window, int, int, unsigned int, unsigned int, unsigned int, unsigned long, unsigned long);
-
- status = (display_name = getenv("DISPLAY"))
- && (handle = dlopen(LIBX11, RTLD_NOW))
- && (pXOpenDisplay = (Display *(*)(char *display_name))dlsym(handle, "XOpenDisplay"))
- && (pXDefaultRootWindow = (Window (*)(Display *))dlsym(handle, "XDefaultRootWindow"))
- && (pXCreateSimpleWindow = (Window (*)(Display *, Window, int, int, unsigned int, unsigned int, unsigned int, unsigned long, unsigned long))dlsym(handle, "XCreateSimpleWindow"))
- && (pXConvertSelection = (int (*)(Display *, Atom, Atom, Atom, Window, Time))dlsym(handle, "XConvertSelection"))
- && (pXPending = (int (*)(Display *display))dlsym(handle, "XPending"))
- && (pXNextEvent = (int (*)(Display *, XEvent *))dlsym(handle, "XNextEvent"))
- && (pXGetWindowProperty = (int (*)(Display *, Window, Atom, long, long, Bool, Atom, Atom *, int *, unsigned long *, unsigned long *, unsigned char **))dlsym(handle, "XGetWindowProperty"))
- && (pXFree = (int (*)(void *))dlsym(handle, "XFree"))
- && (D = pXOpenDisplay(display_name))
- && (R = pXDefaultRootWindow(D))
- && (W = pXCreateSimpleWindow(D, R, 0, 0, 1, 1, 0, 0, 0))
- ? INITIALIZED : FAILED;
- }
-
- if (status == INITIALIZED) {
- XEvent XE;
- Window W2; Atom P;
- Atom type;
- int format;
- unsigned long items, bytes, ignore_bytes;
- unsigned char *buf;
- int timeout;
-
- /* flush late arrivals from previous requests, if any */
- while (pXPending(D)) pXNextEvent(D, &XE);
-
- pXConvertSelection(D, XA_PRIMARY, XA_STRING, XA_STRING, W, CurrentTime);
-
- /* mini event loop to catch response, if any */
- timeout = 20; /* wait two seconds, 100ms at a time */
- for (;;) {
- if (pXPending(D)) {
- pXNextEvent(D, &XE);
- if (XE.type == SelectionNotify) {
- if (XE.xselection.property == None) {
- W2 = R;
- P = XA_CUT_BUFFER0;
- } else {
- W2 = XE.xselection.requestor;
- P = XE.xselection.property;
- }
-
- if (pXGetWindowProperty(D, W2, P, 0, 0, 0, AnyPropertyType,
- &type, &format, &items, &bytes, &buf) == Success
- && type == XA_STRING
- && format == 8) {
- pXFree(buf);
- if (pXGetWindowProperty(D, W2, P, 0, bytes, 0, AnyPropertyType,
- &type, &format, &items, &ignore_bytes, &buf) == Success
- && type == XA_STRING
- && format == 8) {
- p = S_string((char *)buf, (iptr)bytes);
- }
- }
-
- pXFree(buf);
-
- break;
- }
- } else {
- int xfd;
- fd_set rfds;
- struct timeval tv;
-
- if (timeout == 0) break;
- xfd = ConnectionNumber(D);
- FD_ZERO(&rfds);
- FD_SET(xfd, &rfds);
- tv.tv_sec = 0;
- tv.tv_usec = 100*1000;
- select(xfd+1, &rfds, NULL, NULL, &tv);
- timeout -= 1;
- }
- }
- }
-#endif /* LIBX11 */
-
-#ifdef MACOSX
-#define PBPASTEBUFSIZE 1024
- if (p == S_G.null_string) {
- char buf[PBPASTEBUFSIZE];
- FILE *f = popen("/usr/bin/pbpaste", "r");
- iptr i, n, m;
- char *s;
-
- for (;;) {
- ptr newp;
- n = fread(buf, 1, PBPASTEBUFSIZE, f);
- if (n == 0) break;
- n += (m = Sstring_length(p));
- newp = S_string(NULL, n);
- for (i = 0; i != m; i += 1) Sstring_set(newp, i, Sstring_ref(p, i));
- for (s = buf; i != n; i += 1, s += 1)
- Sstring_set(newp, i, *s);
- p = newp;
- }
-
- fclose(f);
- }
-#endif /* MACOSX */
-
- return p;
-}
-
-static void s_ee_write_char(wchar_t wch) {
- locale_t old; char buf[MB_LEN_MAX]; size_t n;
-
- old = uselocale(term_locale);
- n = wcrtomb(buf, wch, &term_in_mbs);
- if (n == (size_t)-1) {
- putchar('?');
- } else {
- fwrite(buf, 1, n, stdout);
- }
- uselocale(old);
-}
-
-#endif /* WIN32 */
-
-static void s_ee_flush(void) {
- fflush(stdout);
-}
-
-void S_expeditor_init(void) {
- Sforeign_symbol("(cs)ee_init_term", (void *)s_ee_init_term);
- Sforeign_symbol("(cs)ee_read_char", (void *)s_ee_read_char);
- Sforeign_symbol("(cs)ee_write_char", (void *)s_ee_write_char);
- Sforeign_symbol("(cs)ee_flush", (void *)s_ee_flush);
- Sforeign_symbol("(cs)ee_get_screen_size", (void *)s_ee_get_screen_size);
- Sforeign_symbol("(cs)ee_raw", (void *)s_ee_raw);
- Sforeign_symbol("(cs)ee_noraw", (void *)s_ee_noraw);
- Sforeign_symbol("(cs)ee_enter_am_mode", (void *)s_ee_enter_am_mode);
- Sforeign_symbol("(cs)ee_exit_am_mode", (void *)s_ee_exit_am_mode);
- Sforeign_symbol("(cs)ee_pause", (void *)s_ee_pause);
- Sforeign_symbol("(cs)ee_nanosleep", (void *)s_ee_nanosleep);
- Sforeign_symbol("(cs)ee_get_clipboard", (void *)s_ee_get_clipboard);
- Sforeign_symbol("(cs)ee_up", (void *)s_ee_up);
- Sforeign_symbol("(cs)ee_down", (void *)s_ee_down);
- Sforeign_symbol("(cs)ee_left", (void *)s_ee_left);
- Sforeign_symbol("(cs)ee_right", (void *)s_ee_right);
- Sforeign_symbol("(cs)ee_clr_eol", (void *)s_ee_clear_eol);
- Sforeign_symbol("(cs)ee_clr_eos", (void *)s_ee_clear_eos);
- Sforeign_symbol("(cs)ee_clear_screen", (void *)s_ee_clear_screen);
- Sforeign_symbol("(cs)ee_scroll_reverse", (void *)s_ee_scroll_reverse);
- Sforeign_symbol("(cs)ee_bell", (void *)s_ee_bell);
- Sforeign_symbol("(cs)ee_carriage_return", (void *)s_ee_carriage_return);
- Sforeign_symbol("(cs)ee_line_feed", (void *)s_ee_line_feed);
-}
-
-#endif /* FEATURE_EXPEDITOR */
diff --git a/ta6ob/c/expeditor.o b/ta6ob/c/expeditor.o
deleted file mode 100644
index f99952d..0000000
Binary files a/ta6ob/c/expeditor.o and /dev/null differ
diff --git a/ta6ob/c/externs.h b/ta6ob/c/externs.h
deleted file mode 100644
index 773f030..0000000
--- a/ta6ob/c/externs.h
+++ /dev/null
@@ -1,415 +0,0 @@
-/* externs.h
- * Copyright 1984-2017 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.
- */
-
-/* This file sets up platform-dependent includes and extern declarations
- * for Scheme globals not intended for use outside of the system (prefixed
- * with S_). Scheme globals intended for use outside of the system
- * (prefixed with S) are declared in scheme.h
- */
-
-#include
-#include
-#include
-#include
-
-#ifndef WIN32
-#include
-
-#if (machine_type == machine_type_i3qnx || machine_type == machine_type_ti3qnx)
-off64_t lseek64(int,off64_t,int);
-#endif
-
-#endif
-
-#ifdef SOLARIS
-#include
-#include
-#include
-#endif
-
-#ifdef WIN32
-#include
-#include /* for _getcwd */
-#include
-#endif
-
-#if !defined(NORETURN)
-# if defined(__GNUC__) || defined(__clang__)
-# define NORETURN __attribute__((noreturn))
-# elif defined(_MSC_VER)
-# define NORETURN __declspec(noreturn)
-# else
-# define NORETURN
-# endif /* defined(__GNUC__) || defined(__clang__) */
-#endif /* !defined(NORETURN) */
-
-/* external procedure declarations */
-/* prototypes gen. by ProtoGen Version 0.31 (Haydn Huntley) 1/18/93 */
-
-/* alloc.c */
-extern void S_alloc_init(void);
-extern void S_protect(ptr *p);
-extern void S_reset_scheme_stack(ptr tc, iptr n);
-extern void S_reset_allocation_pointer(ptr tc);
-extern ptr S_compute_bytes_allocated(ptr xg, ptr xs);
-extern ptr S_find_more_room(ISPC s, IGEN g, iptr n, ptr old);
-extern void S_dirty_set(ptr *loc, ptr x);
-extern void S_mark_card_dirty(uptr card, IGEN to_g);
-extern void S_scan_dirty(ptr **p, ptr **endp);
-extern void S_scan_remembered_set(void);
-extern void S_get_more_room(void);
-extern ptr S_get_more_room_help(ptr tc, uptr ap, uptr type, uptr size);
-extern ptr S_cons_in(ISPC s, IGEN g, ptr car, ptr cdr);
-extern ptr S_symbol(ptr name);
-extern ptr S_rational(ptr n, ptr d);
-extern ptr S_tlc(ptr keyval, ptr tconc, ptr next);
-extern ptr S_vector_in(ISPC s, IGEN g, iptr n);
-extern ptr S_vector(iptr n);
-extern ptr S_fxvector(iptr n);
-extern ptr S_bytevector(iptr n);
-extern ptr S_null_immutable_vector(void);
-extern ptr S_null_immutable_fxvector(void);
-extern ptr S_null_immutable_bytevector(void);
-extern ptr S_null_immutable_string(void);
-extern ptr S_record(iptr n);
-extern ptr S_closure(ptr cod, iptr n);
-extern ptr S_mkcontinuation(ISPC s, IGEN g, ptr nuate, ptr stack,
- iptr length, iptr clength, ptr link, ptr ret, ptr winders);
-extern ptr S_inexactnum(double rp, double ip);
-extern ptr S_exactnum(ptr a, ptr b);
-extern ptr S_thread(ptr tc);
-extern ptr S_string(const char *s, iptr n);
-extern ptr S_bignum(ptr tc, iptr n, IBOOL sign);
-extern ptr S_code(ptr tc, iptr type, iptr n);
-extern ptr S_relocation_table(iptr n);
-extern ptr S_weak_cons(ptr car, ptr cdr);
-
-/* fasl.c */
-extern void S_fasl_init(void);
-ptr S_fasl_read(INT fd, IFASLCODE situation, ptr path);
-ptr S_bv_fasl_read(ptr bv, ptr path);
-ptr S_boot_read(INT fd, const char *path);
-char *S_format_scheme_version(uptr n);
-char *S_lookup_machine_type(uptr n);
-extern void S_set_code_obj(char *who, IFASLCODE typ, ptr p, iptr n,
- ptr x, iptr o);
-extern ptr S_get_code_obj(IFASLCODE typ, ptr p, iptr n, iptr o);
-
-/* flushcache.c */
-extern void S_record_code_mod(ptr tc, uptr addr, uptr bytes);
-extern void S_flush_instruction_cache(ptr tc);
-extern void S_flushcache_init(void);
-
-/* foreign.c */
-extern void S_foreign_init(void);
-extern void S_foreign_entry(void);
-
-/* gcwrapper.c */
-extern void S_ptr_tell(ptr p);
-extern void S_addr_tell(ptr p);
-extern void S_gc_init(void);
-#ifndef WIN32
-extern void S_register_child_process(INT child);
-#endif /* WIN32 */
-extern void S_fixup_counts(ptr counts);
-extern void S_do_gc(IGEN max_cg, IGEN min_tg, IGEN max_tg);
-extern void S_gc(ptr tc, IGEN max_cg, IGEN min_tg, IGEN max_tg);
-extern void S_gc_init(void);
-extern void S_set_maxgen(IGEN g);
-extern IGEN S_maxgen(void);
-extern void S_set_minfreegen(IGEN g);
-extern IGEN S_minfreegen(void);
-#ifndef WIN32
-extern void S_register_child_process(INT child);
-#endif /* WIN32 */
-extern IBOOL S_enable_object_counts(void);
-extern void S_set_enable_object_counts(IBOOL eoc);
-extern ptr S_object_counts(void);
-extern ptr S_locked_objects(void);
-extern ptr S_unregister_guardian(ptr tconc);
-extern void S_compact_heap(void);
-extern void S_check_heap(IBOOL aftergc);
-
-/* gc-011.c */
-extern void S_gc_011(ptr tc);
-
-/* gc-ocd.c */
-extern void S_gc_ocd(ptr tc, IGEN max_cg, IGEN min_tg, IGEN max_tg);
-
-/* gc-oce.c */
-extern void S_gc_oce(ptr tc, IGEN max_cg, IGEN min_tg, IGEN max_tg);
-
-/* intern.c */
-extern void S_intern_init(void);
-extern void S_resize_oblist(void);
-extern ptr S_intern(const unsigned char *s);
-extern ptr S_intern_sc(const string_char *s, iptr n, ptr name_str);
-extern ptr S_intern3(const string_char *pname, iptr plen, const string_char *uname, iptr ulen, ptr pname_str, ptr uame_str);
-extern void S_intern_gensym(ptr g);
-extern void S_retrofit_nonprocedure_code(void);
-
-/* io.c */
-extern IBOOL S_file_existsp(const char *inpath, IBOOL followp);
-extern IBOOL S_file_regularp(const char *inpath, IBOOL followp);
-extern IBOOL S_file_directoryp(const char *inpath, IBOOL followp);
-extern IBOOL S_file_symbolic_linkp(const char *inpath);
-#ifdef WIN32
-extern ptr S_find_files(const char *wildpath);
-#else
-extern ptr S_directory_list(const char *inpath);
-#endif
-extern char *S_malloc_pathname(const char *inpath);
-#ifdef WIN32
-extern wchar_t *S_malloc_wide_pathname(const char *inpath);
-#endif
-extern IBOOL S_fixedpathp(const char *inpath);
-
-/* compress-io.c */
-extern INT S_zlib_compress_level(INT compress_level);
-extern INT S_lz4_compress_level(INT compress_level);
-extern glzFile S_glzdopen_output(INT fd, INT compress_format, INT compress_level);
-extern glzFile S_glzdopen_input(INT fd);
-extern glzFile S_glzopen_input(const char *path);
-#ifdef WIN32
-extern glzFile S_glzopen_input_w(const wchar_t *path);
-#endif
-extern IBOOL S_glzdirect(glzFile file);
-extern INT S_glzclose(glzFile file);
-
-extern INT S_glzread(glzFile file, void *buffer, UINT count);
-extern INT S_glzwrite(glzFile file, void *buffer, UINT count);
-extern long S_glzseek(glzFile file, long offset, INT whence);
-extern INT S_glzgetc(glzFile file);
-extern INT S_glzungetc(INT c, glzFile file);
-extern INT S_glzrewind(glzFile file);
-
-extern void S_glzerror(glzFile file, INT *errnum);
-extern void S_glzclearerr(glzFile fdfile);
-
-
-/* new-io.c */
-extern INT S_gzxfile_fd(ptr x);
-extern glzFile S_gzxfile_gzfile(ptr x);
-extern ptr S_new_open_input_fd(const char *filename, IBOOL compressed);
-extern ptr S_new_open_output_fd(
- const char *filename, INT mode,
- IBOOL no_create, IBOOL no_fail, IBOOL no_truncate,
- IBOOL append, IBOOL lock, IBOOL replace, IBOOL compressed);
-extern ptr S_new_open_input_output_fd(
- const char *filename, INT mode,
- IBOOL no_create, IBOOL no_fail, IBOOL no_truncate,
- IBOOL append, IBOOL lock, IBOOL replace, IBOOL compressed);
-extern ptr S_close_fd(ptr file, IBOOL gzflag);
-extern ptr S_compress_input_fd(INT fd, I64 fp);
-extern ptr S_compress_output_fd(INT fd);
-
-extern ptr S_bytevector_read(ptr file, ptr buffer, iptr start, iptr count, IBOOL gzflag);
-extern ptr S_bytevector_read_nb(ptr file, ptr buffer, iptr start, iptr count, IBOOL gzflag);
-extern ptr S_bytevector_write(ptr file, ptr buffer, iptr start, iptr count, IBOOL gzflag);
-extern ptr S_put_byte(ptr file, INT byte, IBOOL gzflag);
-
-extern ptr S_get_fd_pos(ptr file, IBOOL gzflag);
-extern ptr S_set_fd_pos(ptr file, ptr pos, IBOOL gzflag);
-extern ptr S_get_fd_non_blocking(ptr file, IBOOL gzflag);
-extern ptr S_set_fd_non_blocking(ptr file, IBOOL x, IBOOL gzflag);
-extern ptr S_get_fd_length(ptr file, IBOOL gzflag);
-extern ptr S_set_fd_length(ptr file, ptr length, IBOOL gzflag);
-extern void S_new_io_init(void);
-
-extern uptr S_bytevector_compress_size(iptr s_count, INT compress_format);
-extern ptr S_bytevector_compress(ptr dest_bv, iptr d_start, iptr d_count,
- ptr src_bv, iptr s_start, iptr s_count,
- INT compress_format);
-extern ptr S_bytevector_uncompress(ptr dest_bv, iptr d_start, iptr d_count,
- ptr src_bv, iptr s_start, iptr s_count,
- INT compress_format);
-
-/* thread.c */
-extern void S_thread_init(void);
-extern ptr S_create_thread_object(const char *who, ptr p_tc);
-#ifdef PTHREADS
-extern ptr S_fork_thread(ptr thunk);
-extern scheme_mutex_t *S_make_mutex(void);
-extern void S_mutex_free(scheme_mutex_t *m);
-extern void S_mutex_acquire(scheme_mutex_t *m);
-extern INT S_mutex_tryacquire(scheme_mutex_t *m);
-extern void S_mutex_release(scheme_mutex_t *m);
-extern s_thread_cond_t *S_make_condition(void);
-extern void S_condition_free(s_thread_cond_t *c);
-extern IBOOL S_condition_wait(s_thread_cond_t *c, scheme_mutex_t *m, ptr t);
-extern INT S_activate_thread(void);
-extern void S_unactivate_thread(int mode);
-#endif
-
-/* scheme.c */
-extern void S_generic_invoke(ptr tc, ptr code);
-
-/* number.c */
-extern void S_number_init(void);
-extern ptr S_normalize_bignum(ptr x);
-extern IBOOL S_integer_valuep(ptr x);
-extern iptr S_integer_value(const char *who, ptr x);
-extern I64 S_int64_value(char *who, ptr x);
-extern IBOOL S_big_eq(ptr x, ptr y);
-extern IBOOL S_big_lt(ptr x, ptr y);
-extern ptr S_big_negate(ptr x);
-extern ptr S_add(ptr x, ptr y);
-extern ptr S_sub(ptr x, ptr y);
-extern ptr S_mul(ptr x, ptr y);
-extern ptr S_div(ptr x, ptr y);
-extern ptr S_rem(ptr x, ptr y);
-extern ptr S_trunc(ptr x, ptr y);
-extern void S_trunc_rem(ptr tc, ptr x, ptr y, ptr *q, ptr *r);
-extern ptr S_gcd(ptr x, ptr y);
-extern ptr S_ash(ptr x, ptr n);
-extern ptr S_big_positive_bit_field(ptr x, ptr fxstart, ptr fxend);
-extern ptr S_integer_length(ptr x);
-extern ptr S_big_first_bit_set(ptr x);
-extern double S_random_double(U32 m1, U32 m2,
- U32 m3, U32 m4, double scale);
-extern double S_floatify(ptr x);
-extern ptr S_decode_float(double d);
-extern ptr S_logand(ptr x, ptr y);
-extern ptr S_logbitp(ptr k, ptr x);
-extern ptr S_logbit0(ptr k, ptr x);
-extern ptr S_logbit1(ptr k, ptr x);
-extern ptr S_logtest(ptr x, ptr y);
-extern ptr S_logor(ptr x, ptr y);
-extern ptr S_logxor(ptr x, ptr y);
-extern ptr S_lognot(ptr x);
-
-/* prim.c */
-extern ptr S_lookup_library_entry(iptr n, IBOOL errorp);
-extern ptr S_lookup_c_entry(iptr i);
-extern void S_prim_init(void);
-
-/* prim5.c */
-extern ptr S_strerror(INT errnum);
-extern void S_prim5_init(void);
-extern void S_dump_tc(ptr tc);
-
-/* print.c */
-extern void S_print_init(void);
-extern void S_prin1(ptr x);
-
-/* schsig.c */
-extern ptr S_get_scheme_arg(ptr tc, iptr n);
-extern void S_put_scheme_arg(ptr tc, iptr n, ptr x);
-extern iptr S_continuation_depth(ptr k);
-extern ptr S_single_continuation(ptr k, iptr n);
-extern void S_split_and_resize(void);
-extern void S_handle_overflow(void);
-extern void S_handle_overflood(void);
-extern void S_handle_apply_overflood(void);
-extern void S_overflow(ptr tc, iptr frame_request);
-extern NORETURN void S_error_reset(const char *s);
-extern NORETURN void S_error_abort(const char *s);
-extern NORETURN void S_abnormal_exit(void);
-extern NORETURN void S_error(const char *who, const char *s);
-extern NORETURN void S_error1(const char *who, const char *s, ptr x);
-extern NORETURN void S_error2(const char *who, const char *s, ptr x, ptr y);
-extern NORETURN void S_error3(const char *who, const char *s, ptr x, ptr y, ptr z);
-extern NORETURN void S_boot_error(const ptr who, ptr s, ptr args);
-extern void S_handle_docall_error(void);
-extern void S_handle_arg_error(void);
-extern void S_handle_nonprocedure_symbol(void);
-extern void S_handle_values_error(void);
-extern void S_handle_mvlet_error(void);
-extern ptr S_allocate_scheme_signal_queue(void);
-extern ptr S_dequeue_scheme_signals(ptr tc);
-extern void S_register_scheme_signal(iptr sig);
-extern void S_fire_collector(void);
-extern NORETURN void S_noncontinuable_interrupt(void);
-extern void S_schsig_init(void);
-#ifdef DEFINE_MATHERR
-#include
-extern INT matherr(struct exception *x);
-#endif /* DEFINE_MATHERR */
-
-/* segment.c */
-extern void S_segment_init(void);
-extern void *S_getmem(iptr bytes, IBOOL zerofill);
-extern void S_freemem(void *addr, iptr bytes);
-extern iptr S_find_segments(ISPC s, IGEN g, iptr n);
-extern void S_free_chunk(chunkinfo *chunk);
-extern void S_free_chunks(void);
-extern uptr S_curmembytes(void);
-extern uptr S_maxmembytes(void);
-extern void S_resetmaxmembytes(void);
-extern void S_move_to_chunk_list(chunkinfo *chunk, chunkinfo **pchunk_list);
-
-/* stats.c */
-extern void S_stats_init(void);
-extern ptr S_cputime(void);
-extern ptr S_realtime(void);
-extern ptr S_clock_gettime(I32 typeno);
-extern ptr S_gmtime(ptr tzoff, ptr tspair);
-extern ptr S_asctime(ptr dtvec);
-extern ptr S_mktime(ptr dtvec);
-extern ptr S_unique_id(void);
-extern void S_gettime(INT typeno, struct timespec *tp);
-
-/* symbol.c */
-extern ptr S_symbol_value(ptr sym);
-extern void S_set_symbol_value(ptr sym, ptr val);
-
-/* machine-dependent .c files, e.g., x88k.c */
-#ifdef FLUSHCACHE
-extern INT S_flushcache_max_gap(void);
-extern void S_doflush(uptr start, uptr end);
-#endif
-extern void S_machine_init(void);
-
-/* schlib.c */
-extern void S_initframe(ptr tc, iptr n);
-extern void S_put_arg(ptr tc, iptr i, ptr x);
-extern void S_return(void);
-extern void S_call_help(ptr tc, IBOOL singlep, IBOOL lock_ts);
-extern void S_call_one_result(void);
-extern void S_call_any_results(void);
-
-#ifdef WIN32
-/* windows.c */
-extern INT S_getpagesize(void);
-extern ptr S_LastErrorString(void);
-extern void *S_ntdlopen(const char *path);
-extern void *S_ntdlsym(void *h, const char *s);
-extern ptr S_ntdlerror(void);
-extern int S_windows_flock(int fd, int operation);
-extern int S_windows_chdir(const char *pathname);
-extern int S_windows_chmod(const char *pathname, int mode);
-extern int S_windows_mkdir(const char *pathname);
-extern int S_windows_open(const char *pathname, int flags, int mode);
-extern int S_windows_rename(const char *oldpathname, const char *newpathname);
-extern int S_windows_rmdir(const char *pathname);
-extern int S_windows_stat64(const char *pathname, struct STATBUF *buffer);
-extern int S_windows_system(const char *command);
-extern int S_windows_unlink(const char *pathname);
-extern char *S_windows_getcwd(char *buffer, int maxlen);
-#endif /* WIN32 */
-
-#ifdef _WIN64
-extern int S_setjmp(void* jb);
-extern void S_longjmp(void* jb, int value);
-#endif /* _WIN64 */
-
-#ifdef FEATURE_EXPEDITOR
-/* expeditor.c */
-extern void S_expeditor_init(void);
-#endif /* FEATURE_EXPEDITOR */
-
-/* statics.c */
-extern void scheme_statics(void);
diff --git a/ta6ob/c/fasl.c b/ta6ob/c/fasl.c
deleted file mode 100644
index b0f51fa..0000000
--- a/ta6ob/c/fasl.c
+++ /dev/null
@@ -1,1662 +0,0 @@
-/* fasl.c
- * Copyright 1984-2017 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.
- */
-
-/* fasl representation:
- *
- * -> *
- *
- * -> *
- *
- * -> {header}\0\0\0chez( ...)
- *
- * -> *
- *
- * -> # size is the size in bytes of
- *
- * -> {visit} | {revisit} | {visit-revisit}
- *
- * -> | {uncompressed}
- *
- * -> {gzip} | {lz4}
- *
- * -> {pair}...
- *
- * -> {weak-pair}
- *
- * -> {box}
- *
- * -> {symbol}
- *
- * -> {gensym}
- *
- * -> {string}
- *
- * -> {vector}...
- *
- * -> {fxvector}...
- *
- * -> {bytevector}...
- *
- * -> {immediate}
- *
- * -> {small-integer}
- *
- * -> {large-integer}...
- *
- * -> {ratum}
- *
- * -> {inexactnum}
- *
- * -> {exactnum}
- *
- * -> {flonum}
- *
- * -> {entry}
- *
- * -> {library}
- *
- * -> {library-code}
- *
- * -> {graph}
- *
- * -> {graph-def}
- *
- * -> {graph-ref}
- *
- * -> {base-rtd}
- *
- * -> {rtd}
- *
- * -> {record}
- *
- * -> {eq-hashtable}
- *
- *
- *
- *
- * ...
- * ->
- *
- * -> {symbol-hashtable}
- *
- * ; 0: eq?, 1: eqv?, 2: equal?, 3: symbol=?
- *
- *
- * ...
- * ->
- *
- * -> {closure}
- *
- * -> {code}
- * # number of free variables
- * # length in bytes of code
- *
- * # two's complement encoding of accepted argument counts
- * # inspector info
- * # profiling info
- * ...
- * # length in uptrs of relocation table
- * # first relocation entry
- * ...
- * # last relocation entry
- *
- * -> # bit 0: extended entry, bit 1: expect item offset, bit 2+: type
- *
- * # omitted if bit 1 of type-etc is 0
- *
- *
- * -> ...
- *
- * -> # size in bytes, not necessarily ptr-aligned
- * # number of flds
- *
- *
- * ...
- *
- * ->
- *
- *
- *
- *
- * # 32-bit target
- * # 64-bit target
- * # 32-bit target
- * # 64-bit target
- * # 32-bit target
- * # 64-bit target
- * # 32-bit target
- * # 64-bit target
- *
- *
- * ->
- *
- * -> *
- * -> k << 1 | 1, 0 <= k <= 127
- * -> k << 1 | 0, 0 <= k <= 127
- * each ubyte represents 7 bits of the uptr, least-significant first
- * low-order bit is continuation bit: 1 iff more bytes are present
- *
- * -> | *
- * -> sign << 7 | k << 1 | 1, 0 <= k <= 63
- * -> sign << 7 | k << 1 | 0, 0 <= k <= 63
- * leading ibyte represents least-significant 6 bits and sign
- * each ubyte represents 7 of the remaining bits of the iptr,
- * least-significant first
- *
- * Notes:
- * * a list of length n will appear to be shorter in the fasl
- * representation when the tail of the list is shared, since the
- * shared tail will be a {graph-def} or {graph-ref}.
- *
- * * the length of a relocation table is the number of uptrs in the
- * table, not the number of relocation entries.
- *
- * * closure offset is the amount added to the code object before
- * storing it in the code field of the closure.
- *
- * * {graph} defines the size of the graph used to commonize shared
- * structure, including cycles. It must appear before {graph-def}
- * or {graph-ref}. A {graph-def} at index i must appear before
- * a {graph-ref} at index i.
- *
- * * after an rtd is read: if its uname is unbound, the rtd is placed
- * into the symbol value slot of the uname; otherwise, the rtd is
- * discarded and the existing symbol value of uname is returned
- * instead. Note that when many records appear within the same
- * aggregrate structure, the full rtd will appear only in the
- * first occurrence; the remainder will simply be graph references.
- *
- * * at present, the fasl representation supports only records
- * containing only scheme-object fields.
- */
-
-#include "system.h"
-#include "zlib.h"
-
-#ifdef WIN32
-#include
-#endif /* WIN32 */
-
-#ifdef NAN_INCLUDE
-#include NAN_INCLUDE
-#endif
-
-#define UFFO_TYPE_FD 2
-#define UFFO_TYPE_BV 3
-
-#define PREPARE_BYTEVECTOR(bv,n) {if (bv == Sfalse || Sbytevector_length(bv) < (n)) bv = S_bytevector(n);}
-
-typedef struct unbufFaslFileObj {
- ptr path;
- INT type;
- INT fd;
-} *unbufFaslFile;
-
-typedef struct faslFileObj {
- unbufFaslFile uf;
- iptr size;
- octet *next;
- octet *end;
- octet *buf;
-} *faslFile;
-
-/* locally defined functions */
-static INT uf_read(unbufFaslFile uf, octet *s, iptr n);
-static octet uf_bytein(unbufFaslFile uf);
-static uptr uf_uptrin(unbufFaslFile uf, INT *bytes_consumed);
-static ptr fasl_entry(ptr tc, IFASLCODE situation, unbufFaslFile uf);
-static ptr bv_fasl_entry(ptr tc, ptr bv, unbufFaslFile uf);
-static void fillFaslFile(faslFile f);
-static void bytesin(octet *s, iptr n, faslFile f);
-static void toolarge(ptr path);
-static iptr iptrin(faslFile f);
-static uptr uptrin(faslFile f);
-static float singlein(faslFile f);
-static double doublein(faslFile f);
-static iptr stringin(ptr *pstrbuf, iptr start, faslFile f);
-static void faslin(ptr tc, ptr *x, ptr t, ptr *pstrbuf, faslFile f);
-static void fasl_record(ptr tc, ptr *x, ptr t, ptr *pstrbuf, faslFile f);
-static IBOOL rtd_equiv(ptr x, ptr y);
-static IBOOL equalp(ptr x, ptr y);
-#ifdef ARMV6
-static void arm32_set_abs(void *address, uptr item);
-static uptr arm32_get_abs(void *address);
-static void arm32_set_jump(void *address, uptr item, IBOOL callp);
-static uptr arm32_get_jump(void *address);
-#endif /* ARMV6 */
-#ifdef PPC32
-static void ppc32_set_abs(void *address, uptr item);
-static uptr ppc32_get_abs(void *address);
-static void ppc32_set_jump(void *address, uptr item, IBOOL callp);
-static uptr ppc32_get_jump(void *address);
-#endif /* PPC32 */
-#ifdef X86_64
-static void x86_64_set_jump(void *address, uptr item, IBOOL callp);
-static uptr x86_64_get_jump(void *address);
-#endif /* X86_64 */
-#ifdef SPARC64
-static INT extract_reg_from_sethi(void *address);
-static void emit_sethi_lo(U32 item, INT destreg, void *address);
-static uptr sparc64_get_literal(void *address);
-static void sparc64_set_call(void *address, U32 *call_addr, uptr item);
-static U32 adjust_delay_inst(U32 delay_inst, U32 *old_call_addr, U32 *new_call_addr);
-static INT sparc64_set_lit_only(void *address, uptr item, I32 destreg);
-static void sparc64_set_literal(void *address, uptr item);
-#endif /* SPARC64 */
-
-static double s_nan;
-
-void S_fasl_init(void) {
- if (S_boot_time) {
- S_protect(&S_G.base_rtd);
- S_G.base_rtd = Sfalse;
- S_protect(&S_G.rtd_key);
- S_G.rtd_key = S_intern((const unsigned char *)"*rtd*");
- S_protect(&S_G.eq_symbol);
- S_G.eq_symbol = S_intern((const unsigned char *)"eq");
- S_protect(&S_G.eq_ht_rtd);
- S_G.eq_ht_rtd = Sfalse;
- S_protect(&S_G.symbol_symbol);
- S_G.symbol_symbol = S_intern((const unsigned char *)"symbol");
- S_protect(&S_G.symbol_ht_rtd);
- S_G.symbol_ht_rtd = Sfalse;
- S_protect(&S_G.eqp);
- S_G.eqp = Sfalse;
- S_protect(&S_G.eqvp);
- S_G.eqvp = Sfalse;
- S_protect(&S_G.equalp);
- S_G.equalp = Sfalse;
- S_protect(&S_G.symboleqp);
- S_G.symboleqp = Sfalse;
- }
-
- MAKE_NAN(s_nan)
-#ifndef WIN32 /* msvc returns true for s_nan==s_nan! */
- if (s_nan == s_nan) {
- fprintf(stderr, "s_nan == s_nan\n");
- S_abnormal_exit();
- }
-#endif
-}
-
-ptr S_fasl_read(INT fd, IFASLCODE situation, ptr path) {
- ptr tc = get_thread_context();
- ptr x; struct unbufFaslFileObj uffo;
-
- /* acquire mutex in case we modify code pages */
- tc_mutex_acquire()
- uffo.path = path;
- uffo.type = UFFO_TYPE_FD;
- uffo.fd = fd;
- x = fasl_entry(tc, situation, &uffo);
- tc_mutex_release()
- return x;
-}
-
-ptr S_bv_fasl_read(ptr bv, ptr path) {
- ptr tc = get_thread_context();
- ptr x; struct unbufFaslFileObj uffo;
-
- /* acquire mutex in case we modify code pages */
- tc_mutex_acquire()
- uffo.path = path;
- uffo.type = UFFO_TYPE_BV;
- x = bv_fasl_entry(tc, bv, &uffo);
- tc_mutex_release()
- return x;
-}
-
-ptr S_boot_read(INT fd, const char *path) {
- ptr tc = get_thread_context();
- struct unbufFaslFileObj uffo;
-
- uffo.path = Sstring_utf8(path, -1);
- uffo.type = UFFO_TYPE_FD;
- uffo.fd = fd;
- return fasl_entry(tc, fasl_type_visit_revisit, &uffo);
-}
-
-#ifdef WIN32
-#define IO_SIZE_T unsigned int
-#else /* WIN32 */
-#define IO_SIZE_T size_t
-#endif /* WIN32 */
-
-static INT uf_read(unbufFaslFile uf, octet *s, iptr n) {
- iptr k;
- while (n > 0) {
- uptr nx = n;
-
-#if (iptr_bits > 32)
- if (WIN32 && (unsigned int)nx != nx) nx = 0xffffffff;
-#endif
-
- switch (uf->type) {
- case UFFO_TYPE_FD:
- k = READ(uf->fd, s, (IO_SIZE_T)nx);
- if (k > 0)
- n -= k;
- else if (k == 0)
- return -1;
- else if (errno != EINTR)
- S_error1("", "error reading from ~a", uf->path);
- break;
- default:
- return -1;
- }
-
- s += k;
- }
- return 0;
-}
-
-static void uf_skipbytes(unbufFaslFile uf, iptr n) {
- switch (uf->type) {
- case UFFO_TYPE_FD:
- if (LSEEK(uf->fd, n, SEEK_CUR) == -1) {
- S_error1("", "error seeking ~a", uf->path);
- }
- break;
- }
-}
-
-static octet uf_bytein(unbufFaslFile uf) {
- octet buf[1];
- if (uf_read(uf, buf, 1) < 0)
- S_error1("", "unexpected eof in fasl file ~a", uf->path);
- return buf[0];
-}
-
-static uptr uf_uptrin(unbufFaslFile uf, INT *bytes_consumed) {
- uptr n, m; octet k;
-
- if (bytes_consumed) *bytes_consumed = 1;
- k = uf_bytein(uf);
- n = k >> 1;
- while (k & 1) {
- if (bytes_consumed) *bytes_consumed += 1;
- k = uf_bytein(uf);
- m = n << 7;
- if (m >> 7 != n) toolarge(uf->path);
- n = m | (k >> 1);
- }
-
- return n;
-}
-
-char *S_format_scheme_version(uptr n) {
- static char buf[16]; INT len;
- if ((n >> 16) != ((n >> 16) & 0xffff)) return "unknown";
- if ((n & 0xff) == 0)
- len = snprintf(buf, 16, "%d.%d", (int) n >> 16, (int) (n >> 8) & 0xff);
- else
- len = snprintf(buf, 16, "%d.%d.%d", (int) n >> 16, (int) (n >> 8) & 0xff,
- (int) n & 0xff);
- return len > 0 ? buf : "unknown";
-}
-
-char *S_lookup_machine_type(uptr n) {
- static char *machine_type_table[] = machine_type_names;
- if (n < machine_type_limit)
- return machine_type_table[n];
- else
- return "unknown";
-}
-
-static ptr fasl_entry(ptr tc, IFASLCODE situation, unbufFaslFile uf) {
- ptr x; ptr strbuf = S_G.null_string;
- octet tybuf[1]; IFASLCODE ty; iptr size;
- /* gcc (GCC) 4.8.5 20150623 (Red Hat 4.8.5-28) co-locates buf and x if we put the declaration of buf down where we use it */
- octet buf[SBUFSIZ];
-
- for (;;) {
- if (uf_read(uf, tybuf, 1) < 0) return Seof_object;
- ty = tybuf[0];
-
- while (ty == fasl_type_header) {
- uptr n; ICHAR c;
-
- /* check for remainder of magic number */
- if (uf_bytein(uf) != 0 ||
- uf_bytein(uf) != 0 ||
- uf_bytein(uf) != 0 ||
- uf_bytein(uf) != 'c' ||
- uf_bytein(uf) != 'h' ||
- uf_bytein(uf) != 'e' ||
- uf_bytein(uf) != 'z')
- S_error1("", "malformed fasl-object header (missing magic word) found in ~a", uf->path);
-
- if ((n = uf_uptrin(uf, (INT *)0)) != scheme_version)
- S_error2("", "incompatible fasl-object version ~a found in ~a", S_string(S_format_scheme_version(n), -1), uf->path);
-
- if ((n = uf_uptrin(uf, (INT *)0)) != machine_type_any && n != machine_type)
- S_error2("", "incompatible fasl-object machine-type ~a found in ~a", S_string(S_lookup_machine_type(n), -1), uf->path);
-
- if (uf_bytein(uf) != '(')
- S_error1("", "malformed fasl-object header (missing open paren) found in ~a", uf->path);
-
- while ((c = uf_bytein(uf)) != ')')
- if (c < 0) S_error1("", "malformed fasl-object header (missing close paren) found in ~a", uf->path);
-
- ty = uf_bytein(uf);
- }
-
- switch (ty) {
- case fasl_type_visit:
- case fasl_type_revisit:
- case fasl_type_visit_revisit:
- break;
- default:
- S_error2("", "malformed fasl-object header (missing situation, got ~s) found in ~a", FIX(ty), uf->path);
- return (ptr)0;
- }
-
- size = uf_uptrin(uf, (INT *)0);
-
- if (ty == situation || situation == fasl_type_visit_revisit || ty == fasl_type_visit_revisit) {
- struct faslFileObj ffo;
-
- ty = uf_bytein(uf);
- switch (ty) {
- case fasl_type_gzip:
- case fasl_type_lz4: {
- ptr result; INT bytes_consumed;
- iptr dest_size = uf_uptrin(uf, &bytes_consumed);
- iptr src_size = size - (1 + bytes_consumed); /* adjust for u8 compression type and uptr dest_size */
-
- PREPARE_BYTEVECTOR(SRCBV(tc), src_size);
- PREPARE_BYTEVECTOR(DSTBV(tc), dest_size);
- if (uf_read(uf, &BVIT(SRCBV(tc),0), src_size) < 0)
- S_error1("", "unexpected eof in fasl file ~a", uf->path);
- result = S_bytevector_uncompress(DSTBV(tc), 0, dest_size, SRCBV(tc), 0, src_size,
- (ty == fasl_type_gzip ? COMPRESS_GZIP : COMPRESS_LZ4));
- if (result != FIX(dest_size)) {
- if (Sstringp(result)) S_error2("fasl-read", "~@?", result, SRCBV(tc));
- S_error3("fasl-read", "uncompressed size ~s for ~s is smaller than expected size ~s", result, SRCBV(tc), FIX(dest_size));
- }
- ffo.size = dest_size;
- ffo.next = ffo.buf = &BVIT(DSTBV(tc),0);
- ffo.end = &BVIT(DSTBV(tc),dest_size);
- ffo.uf = uf;
- break;
- }
- case fasl_type_uncompressed: {
- ffo.size = size - 1; /* adjust for u8 compression type */
- ffo.next = ffo.end = ffo.buf = buf;
- ffo.uf = uf;
- break;
- }
- default:
- S_error2("", "malformed fasl-object header (missing possibly-compressed, got ~s) found in ~a", FIX(ty), uf->path);
- return (ptr)0;
- }
- faslin(tc, &x, S_G.null_vector, &strbuf, &ffo);
- S_flush_instruction_cache(tc);
- return x;
- } else {
- uf_skipbytes(uf, size);
- }
- }
-}
-
-static ptr bv_fasl_entry(ptr tc, ptr bv, unbufFaslFile uf) {
- ptr x; ptr strbuf = S_G.null_string;
- struct faslFileObj ffo;
-
- ffo.size = Sbytevector_length(bv);
- ffo.next = ffo.buf = &BVIT(bv, 0);
- ffo.end = &BVIT(bv, ffo.size);
- ffo.uf = uf;
-
- faslin(tc, &x, S_G.null_vector, &strbuf, &ffo);
- S_flush_instruction_cache(tc);
- return x;
-}
-
-static void fillFaslFile(faslFile f) {
- iptr n = f->size < SBUFSIZ ? f->size : SBUFSIZ;
- if (uf_read(f->uf, f->buf, n) < 0)
- S_error1("", "unexpected eof in fasl file ~a", f->uf->path);
- f->end = (f->next = f->buf) + n;
- f->size -= n;
-}
-
-#define bytein(f) ((((f)->next == (f)->end) ? fillFaslFile(f) : (void)0), *((f)->next++))
-
-static void bytesin(octet *s, iptr n, faslFile f) {
- iptr avail = f->end - f->next;
- if (avail < n) {
- if (avail != 0) {
- memcpy(s, f->next, avail);
- f->next = f->end;
- n -= avail;
- s += avail;
- }
- if (uf_read(f->uf, s, n) < 0)
- S_error1("", "unexpected eof in fasl file ~a", f->uf->path);
- f->size -= n;
- } else {
- memcpy(s, f->next, n);
- f->next += n;
- }
-}
-
-static void toolarge(ptr path) {
- S_error1("", "fasl value too large for this machine type in ~a", path);
-}
-
-static iptr iptrin(faslFile f) {
- uptr n, m; octet k, k0;
-
- k0 = k = bytein(f);
- n = (k & 0x7f) >> 1;
- while (k & 1) {
- k = bytein(f);
- m = n << 7;
- if (m >> 7 != n) toolarge(f->uf->path);
- n = m | (k >> 1);
- }
-
- if (k0 & 0x80) {
- if (n < ((uptr)1 << (ptr_bits - 1))) {
- return -(iptr)n;
- } else if (n > ((uptr)1 << (ptr_bits - 1))) {
- toolarge(f->uf->path);
- }
-#if (fixnum_bits > 32)
- return (iptr)0x8000000000000000;
-#else
- return (iptr)0x80000000;
-#endif
- } else {
- if (n >= ((uptr)1 << (ptr_bits - 1))) toolarge(f->uf->path);
- return (iptr)n;
- }
-}
-
-static uptr uptrin(faslFile f) {
- uptr n, m; octet k;
-
- k = bytein(f);
- n = k >> 1;
- while (k & 1) {
- k = bytein(f);
- m = n << 7;
- if (m >> 7 != n) toolarge(f->uf->path);
- n = m | (k >> 1);
- }
-
- return n;
-}
-
-static float singlein(faslFile f) {
- union { float f; U32 u; } val;
-
- val.u = (U32)uptrin(f);
-
- return val.f;
-}
-
-static double doublein(faslFile f) {
-#ifdef LITTLE_ENDIAN_IEEE_DOUBLE
- union { double d; struct { U32 l; U32 h; } u; } val;
-#else
- union { double d; struct { U32 h; U32 l; } u; } val;
-#endif
-
- val.u.h = (U32)uptrin(f);
- val.u.l = (U32)uptrin(f);
-
- return val.d;
-}
-
-static iptr stringin(ptr *pstrbuf, iptr start, faslFile f) {
- iptr end, n, i; ptr p = *pstrbuf;
-
- end = start + (n = uptrin(f));
- if (Sstring_length(*pstrbuf) < end) {
- ptr newp = S_string((char *)0, end);
- for (i = 0; i != start; i += 1) Sstring_set(newp, i, Sstring_ref(p, i));
- *pstrbuf = p = newp;
- }
- for (i = start; i != end; i += 1) Sstring_set(p, i, uptrin(f));
- return n;
-}
-
-static void faslin(ptr tc, ptr *x, ptr t, ptr *pstrbuf, faslFile f) {
- IFASLCODE ty = bytein(f);
- switch (ty) {
- case fasl_type_pair: {
- iptr n; ptr p;
- n = uptrin(f);
- *x = p = Scons(FIX(0), FIX(0));
- faslin(tc, &INITCAR(p), t, pstrbuf, f);
- while (--n) {
- INITCDR(p) = Scons(FIX(0), FIX(0));
- p = INITCDR(p);
- faslin(tc, &INITCAR(p), t, pstrbuf, f);
- }
- faslin(tc, &INITCDR(p), t, pstrbuf, f);
- return;
- }
- case fasl_type_box:
- case fasl_type_immutable_box:
- *x = Sbox(FIX(0));
- faslin(tc, &INITBOXREF(*x), t, pstrbuf, f);
- if (ty == fasl_type_immutable_box)
- BOXTYPE(*x) = type_immutable_box;
- return;
- case fasl_type_symbol: {
- iptr n;
- n = stringin(pstrbuf, 0, f);
- *x = S_intern_sc(&STRIT(*pstrbuf, 0), n, Sfalse);
- return;
- }
- case fasl_type_gensym: {
- iptr pn, un;
- pn = stringin(pstrbuf, 0, f);
- un = stringin(pstrbuf, pn, f);
- *x = S_intern3(&STRIT(*pstrbuf, 0), pn, &STRIT(*pstrbuf, pn), un, Sfalse, Sfalse);
- return;
- }
- case fasl_type_ratnum:
- *x = S_rational(FIX(0), FIX(0));
- faslin(tc, &RATNUM(*x), t, pstrbuf, f);
- faslin(tc, &RATDEN(*x), t, pstrbuf, f);
- return;
- case fasl_type_exactnum:
- *x = S_exactnum(FIX(0), FIX(0));
- faslin(tc, &EXACTNUM_REAL_PART(*x), t, pstrbuf, f);
- faslin(tc, &EXACTNUM_IMAG_PART(*x), t, pstrbuf, f);
- return;
- case fasl_type_vector:
- case fasl_type_immutable_vector: {
- iptr n; ptr *p;
- n = uptrin(f);
- *x = S_vector(n);
- p = &INITVECTIT(*x, 0);
- while (n--) faslin(tc, p++, t, pstrbuf, f);
- if (ty == fasl_type_immutable_vector) {
- if (Svector_length(*x) == 0)
- *x = NULLIMMUTABLEVECTOR(tc);
- else
- VECTTYPE(*x) |= vector_immutable_flag;
- }
- return;
- }
- case fasl_type_fxvector:
- case fasl_type_immutable_fxvector: {
- iptr n; ptr *p;
- n = uptrin(f);
- *x = S_fxvector(n);
- p = &FXVECTIT(*x, 0);
- while (n--) {
- iptr t = iptrin(f);
- if (!FIXRANGE(t)) toolarge(f->uf->path);
- *p++ = FIX(t);
- }
- if (ty == fasl_type_immutable_fxvector) {
- if (Sfxvector_length(*x) == 0)
- *x = NULLIMMUTABLEFXVECTOR(tc);
- else
- FXVECTOR_TYPE(*x) |= fxvector_immutable_flag;
- }
- return;
- }
- case fasl_type_bytevector:
- case fasl_type_immutable_bytevector: {
- iptr n;
- n = uptrin(f);
- *x = S_bytevector(n);
- bytesin(&BVIT(*x,0), n, f);
- if (ty == fasl_type_immutable_bytevector) {
- if (Sbytevector_length(*x) == 0)
- *x = NULLIMMUTABLEBYTEVECTOR(tc);
- else
- BYTEVECTOR_TYPE(*x) |= bytevector_immutable_flag;
- }
- return;
- }
- case fasl_type_base_rtd: {
- ptr rtd;
- if ((rtd = S_G.base_rtd) == Sfalse) {
- if (!Srecordp(rtd)) S_error_abort("S_G.base-rtd has not been set");
- }
- *x = rtd;
- return;
- } case fasl_type_rtd: {
- ptr rtd, rtd_uid, plist, ls;
-
- faslin(tc, &rtd_uid, t, pstrbuf, f);
-
- /* look for rtd on uid's property list */
- plist = SYMSPLIST(rtd_uid);
- for (ls = plist; ls != Snil; ls = Scdr(Scdr(ls))) {
- if (Scar(ls) == S_G.rtd_key) {
- ptr tmp;
- *x = rtd = Scar(Scdr(ls));
- fasl_record(tc, &tmp, t, pstrbuf, f);
- if (!rtd_equiv(tmp, rtd))
- S_error2("", "incompatible record type ~s in ~a", RECORDDESCNAME(tmp), f->uf->path);
- return;
- }
- }
-
- fasl_record(tc, x, t, pstrbuf, f);
- rtd = *x;
-
- /* register rtd on uid's property list */
- SETSYMSPLIST(rtd_uid, Scons(S_G.rtd_key, Scons(rtd, plist)));
- return;
- }
- case fasl_type_record: {
- fasl_record(tc, x, t, pstrbuf, f);
- return;
- }
- case fasl_type_eq_hashtable: {
- ptr rtd, ht, v; uptr subtype; uptr veclen, i, n;
- if ((rtd = S_G.eq_ht_rtd) == Sfalse) {
- S_G.eq_ht_rtd = rtd = SYMVAL(S_intern((const unsigned char *)"$eq-ht-rtd"));
- if (!Srecordp(rtd)) S_error_abort("$eq-ht-rtd has not been set");
- }
- *x = ht = S_record(size_record_inst(UNFIX(RECORDDESCSIZE(rtd))));
- RECORDINSTTYPE(ht) = rtd;
- INITPTRFIELD(ht,eq_hashtable_type_disp) = S_G.eq_symbol;
- INITPTRFIELD(ht,eq_hashtable_mutablep_disp) = bytein(f) ? Strue : Sfalse;
- switch ((subtype = bytein(f))) {
- case eq_hashtable_subtype_normal:
- case eq_hashtable_subtype_weak:
- case eq_hashtable_subtype_ephemeron:
- INITPTRFIELD(ht,eq_hashtable_subtype_disp) = FIX(subtype);
- break;
- default:
- S_error2("", "invalid eq-hashtable subtype code", FIX(subtype), f->uf->path);
- }
- INITPTRFIELD(ht,eq_hashtable_minlen_disp) = FIX(uptrin(f));
- veclen = uptrin(f);
- INITPTRFIELD(ht,eq_hashtable_vec_disp) = v = S_vector(veclen);
- n = uptrin(f);
- INITPTRFIELD(ht,eq_hashtable_size_disp) = FIX(n);
- for (i = 0; i < veclen ; i += 1) { INITVECTIT(v, i) = FIX(i); }
- while (n > 0) {
- ptr keyval;
- switch (subtype) {
- case eq_hashtable_subtype_normal:
- keyval = Scons(FIX(0), FIX(0));
- break;
- case eq_hashtable_subtype_weak:
- keyval = S_cons_in(space_weakpair, 0, FIX(0), FIX(0));
- break;
- case eq_hashtable_subtype_ephemeron:
- default:
- keyval = S_cons_in(space_ephemeron, 0, FIX(0), FIX(0));
- break;
- }
- faslin(tc, &INITCAR(keyval), t, pstrbuf, f);
- faslin(tc, &INITCDR(keyval), t, pstrbuf, f);
- i = ((uptr)Scar(keyval) >> primary_type_bits) & (veclen - 1);
- INITVECTIT(v, i) = S_tlc(keyval, ht, Svector_ref(v, i));
- n -= 1;
- }
- return;
- }
- case fasl_type_symbol_hashtable: {
- ptr rtd, ht, equiv, v; uptr equiv_code, veclen, i, n;
- if ((rtd = S_G.symbol_ht_rtd) == Sfalse) {
- S_G.symbol_ht_rtd = rtd = SYMVAL(S_intern((const unsigned char *)"$symbol-ht-rtd"));
- if (!Srecordp(rtd)) S_error_abort("$symbol-ht-rtd has not been set");
- }
- *x = ht = S_record(size_record_inst(UNFIX(RECORDDESCSIZE(rtd))));
- RECORDINSTTYPE(ht) = rtd;
- INITPTRFIELD(ht,symbol_hashtable_type_disp) = S_G.symbol_symbol;
- INITPTRFIELD(ht,symbol_hashtable_mutablep_disp) = bytein(f) ? Strue : Sfalse;
- INITPTRFIELD(ht,symbol_hashtable_minlen_disp) = FIX(uptrin(f));
- equiv_code = bytein(f);
- switch (equiv_code) {
- case 0:
- if ((equiv = S_G.eqp) == Sfalse) {
- S_G.eqp = equiv = SYMVAL(S_intern((const unsigned char *)"eq?"));
- if (!Sprocedurep(equiv)) S_error_abort("fasl: eq? has not been set");
- }
- break;
- case 1:
- if ((equiv = S_G.eqvp) == Sfalse) {
- S_G.eqvp = equiv = SYMVAL(S_intern((const unsigned char *)"eqv?"));
- if (!Sprocedurep(equiv)) S_error_abort("fasl: eqv? has not been set");
- }
- break;
- case 2:
- if ((equiv = S_G.equalp) == Sfalse) {
- S_G.equalp = equiv = SYMVAL(S_intern((const unsigned char *)"equal?"));
- if (!Sprocedurep(equiv)) S_error_abort("fasl: equal? has not been set");
- }
- break;
- case 3:
- if ((equiv = S_G.symboleqp) == Sfalse) {
- S_G.symboleqp = equiv = SYMVAL(S_intern((const unsigned char *)"symbol=?"));
- if (!Sprocedurep(equiv)) S_error_abort("fasl: symbol=? has not been set");
- }
- break;
- default:
- S_error2("", "invalid symbol-hashtable equiv code", FIX(equiv_code), f->uf->path);
- /* make compiler happy */
- equiv = Sfalse;
- }
- INITPTRFIELD(ht,symbol_hashtable_equivp_disp) = equiv;
- veclen = uptrin(f);
- INITPTRFIELD(ht,symbol_hashtable_vec_disp) = v = S_vector(veclen);
- n = uptrin(f);
- INITPTRFIELD(ht,symbol_hashtable_size_disp) = FIX(n);
- for (i = 0; i < veclen ; i += 1) { INITVECTIT(v, i) = Snil; }
- while (n > 0) {
- ptr keyval;
- keyval = Scons(FIX(0), FIX(0));
- faslin(tc, &INITCAR(keyval), t, pstrbuf, f);
- faslin(tc, &INITCDR(keyval), t, pstrbuf, f);
- i = UNFIX(SYMHASH(Scar(keyval))) & (veclen - 1);
- INITVECTIT(v, i) = Scons(keyval, Svector_ref(v, i));
- n -= 1;
- }
- return;
- }
- case fasl_type_closure: {
- ptr cod; iptr offset;
- offset = uptrin(f);
- *x = S_closure((ptr)0, 0);
- faslin(tc, &cod, t, pstrbuf, f);
- CLOSENTRY(*x) = (ptr)((uptr)cod + offset);
- return;
- }
- case fasl_type_flonum: {
- *x = Sflonum(doublein(f));
- return;
- }
- case fasl_type_inexactnum: {
- ptr rp, ip;
- faslin(tc, &rp, t, pstrbuf, f);
- faslin(tc, &ip, t, pstrbuf, f);
- *x = S_inexactnum(FLODAT(rp), FLODAT(ip));
- return;
- }
- case fasl_type_string:
- case fasl_type_immutable_string: {
- iptr i, n; ptr str;
- n = uptrin(f);
- str = S_string((char *)0, n);
- for (i = 0; i != n; i += 1) Sstring_set(str, i, uptrin(f));
- if (ty == fasl_type_immutable_string) {
- if (n == 0)
- str = NULLIMMUTABLESTRING(tc);
- else
- STRTYPE(str) |= string_immutable_flag;
- }
- *x = str;
- return;
- }
- case fasl_type_small_integer:
- *x = Sinteger(iptrin(f));
- return;
- case fasl_type_large_integer: {
- IBOOL sign; iptr n; ptr t; bigit *p;
- sign = bytein(f);
- n = uptrin(f);
- t = S_bignum(tc, n, sign);
- p = &BIGIT(t, 0);
- while (n--) *p++ = (bigit)uptrin(f);
- *x = S_normalize_bignum(t);
- return;
- }
- case fasl_type_weak_pair:
- *x = S_cons_in(space_weakpair, 0, FIX(0), FIX(0));
- faslin(tc, &INITCAR(*x), t, pstrbuf, f);
- faslin(tc, &INITCDR(*x), t, pstrbuf, f);
- return;
- case fasl_type_ephemeron:
- *x = S_cons_in(space_ephemeron, 0, FIX(0), FIX(0));
- faslin(tc, &INITCAR(*x), t, pstrbuf, f);
- faslin(tc, &INITCDR(*x), t, pstrbuf, f);
- return;
- case fasl_type_code: {
- iptr n, m, a; INT flags; iptr free;
- ptr co, reloc, name, pinfos;
- flags = bytein(f);
- free = uptrin(f);
- n = uptrin(f) /* length in bytes of code */;
- *x = co = S_code(tc, type_code | (flags << code_flags_offset), n);
- CODEFREE(co) = free;
- faslin(tc, &name, t, pstrbuf, f);
- if (Sstringp(name)) name = SYMNAME(S_intern_sc(&STRIT(name, 0), Sstring_length(name), name));
- CODENAME(co) = name;
- faslin(tc, &CODEARITYMASK(co), t, pstrbuf, f);
- faslin(tc, &CODEINFO(co), t, pstrbuf, f);
- faslin(tc, &pinfos, t, pstrbuf, f);
- CODEPINFOS(co) = pinfos;
- if (pinfos != Snil) {
- S_G.profile_counters = Scons(S_weak_cons(co, pinfos), S_G.profile_counters);
- }
- bytesin((octet *)&CODEIT(co, 0), n, f);
- m = uptrin(f);
- CODERELOC(co) = reloc = S_relocation_table(m);
- RELOCCODE(reloc) = co;
- a = 0;
- n = 0;
- while (n < m) {
- INT type_etc, type; uptr item_off, code_off;
- ptr obj;
- type_etc = bytein(f);
- type = type_etc >> 2;
- code_off = uptrin(f);
- item_off = (type_etc & 2) ? uptrin(f) : 0;
- if (type_etc & 1) {
- RELOCIT(reloc,n) = (type << reloc_type_offset)|reloc_extended_format ; n += 1;
- RELOCIT(reloc,n) = item_off; n += 1;
- RELOCIT(reloc,n) = code_off; n += 1;
- } else {
- RELOCIT(reloc,n) = MAKE_SHORT_RELOC(type,code_off,item_off); n += 1;
- }
- a += code_off;
- faslin(tc, &obj, t, pstrbuf, f);
- S_set_code_obj("read", type, co, a, obj, item_off);
- }
- return;
- }
- case fasl_type_immediate:
- *x = (ptr)uptrin(f);
- return;
- case fasl_type_entry:
- *x = (ptr)S_lookup_c_entry(uptrin(f));
- return;
- case fasl_type_library:
- *x = S_lookup_library_entry(uptrin(f), 1);
- return;
- case fasl_type_library_code:
- *x = CLOSCODE(S_lookup_library_entry(uptrin(f), 1));
- return;
- case fasl_type_graph:
- faslin(tc, x, S_vector(uptrin(f)), pstrbuf, f);
- return;
- case fasl_type_graph_def: {
- ptr *p;
- p = &INITVECTIT(t, uptrin(f));
- faslin(tc, p, t, pstrbuf, f);
- *x = *p;
- return;
- }
- case fasl_type_graph_ref:
- *x = Svector_ref(t, uptrin(f));
- return;
- default:
- S_error2("", "invalid object type ~d in fasl file ~a", FIX(ty), f->uf->path);
- }
-}
-
-#define big 0
-#define little 1
-static void fasl_record(ptr tc, ptr *x, ptr t, ptr *pstrbuf, faslFile f) {
- uptr size, n, addr; ptr p; UINT padty;
-
- size = uptrin(f);
- n = uptrin(f);
- *x = p = S_record(size_record_inst(size));
- faslin(tc, &RECORDINSTTYPE(p), t, pstrbuf, f);
- addr = (uptr)&RECORDINSTIT(p, 0);
- for (; n != 0; n -= 1) {
- padty = bytein(f);
- addr += padty >> 4;
- switch (padty & 0xf) {
- case fasl_fld_ptr:
- faslin(tc, (ptr *)addr, t, pstrbuf, f);
- addr += sizeof(ptr);
- break;
- case fasl_fld_u8:
- *(U8 *)addr = (U8)bytein(f);
- addr += 1;
- break;
- case fasl_fld_i16:
- *(I16 *)addr = (I16)iptrin(f);
- addr += 2;
- break;
- case fasl_fld_i24: {
- iptr q = iptrin(f);
-#if (native_endianness == little)
- *(U16 *)addr = (U16)q;
- *(U8 *)(addr + 2) = (U8)(q >> 16);
-#elif (native_endianness == big)
- *(U16 *)addr = (U16)(q >> 8);
- *(U8 *)(addr + 2) = (U8)q;
-#else
- unexpected_endianness();
-#endif
- addr += 3;
- break;
- }
- case fasl_fld_i32:
- *(I32 *)addr = (I32)iptrin(f);
- addr += 4;
- break;
- case fasl_fld_i40: {
- I64 q;
-#if (ptr_bits == 32)
- q = (I64)iptrin(f) << 32;
- q |= (U32)uptrin(f);
-#elif (ptr_bits == 64)
- q = (I64)iptrin(f);
-#else
- unexpected_ptr_bits();
-#endif
-#if (native_endianness == little)
- *(U32 *)addr = (U32)q;
- *(U8 *)(addr + 4) = (U8)(q >> 32);
-#elif (native_endianness == big)
- *(U32 *)addr = (U32)(q >> 8);
- *(U8 *)(addr + 4) = (U8)q;
-#else
- unexpected_endianness();
-#endif
- addr += 5;
- break;
- }
- case fasl_fld_i48: {
- I64 q;
-#if (ptr_bits == 32)
- q = (I64)iptrin(f) << 32;
- q |= (U32)uptrin(f);
-#elif (ptr_bits == 64)
- q = (I64)iptrin(f);
-#else
- unexpected_ptr_bits();
-#endif
-#if (native_endianness == little)
- *(U32 *)addr = (U32)q;
- *(U16 *)(addr + 4) = (U16)(q >> 32);
-#elif (native_endianness == big)
- *(U32 *)addr = (U32)(q >> 16);
- *(U16 *)(addr + 4) = (U16)q;
-#else
- unexpected_endianness();
-#endif
- addr += 6;
- break;
- }
- case fasl_fld_i56: {
- I64 q;
-#if (ptr_bits == 32)
- q = (I64)iptrin(f) << 32;
- q |= (U32)uptrin(f);
-#elif (ptr_bits == 64)
- q = (I64)iptrin(f);
-#else
- unexpected_ptr_bits();
-#endif
-#if (native_endianness == little)
- *(U32 *)addr = (U32)q;
- *(U16 *)(addr + 4) = (U16)(q >> 32);
- *(U8 *)(addr + 6) = (U8)(q >> 48);
-#elif (native_endianness == big)
- *(U32 *)addr = (U32)(q >> 24);
- *(U32 *)(addr + 3) = (U32)q;
-#else
- unexpected_endianness();
-#endif
- addr += 7;
- break;
- }
- case fasl_fld_i64: {
- I64 q;
-#if (ptr_bits == 32)
- q = (I64)iptrin(f) << 32;
- q |= (U32)uptrin(f);
-#elif (ptr_bits == 64)
- q = (I64)iptrin(f);
-#else
- unexpected_ptr_bits();
-#endif
- *(I64 *)addr = q;
- addr += 8;
- break;
- }
- case fasl_fld_single:
- *(float *)addr = (float)singlein(f);
- addr += sizeof(float);
- break;
- case fasl_fld_double:
- *(double *)addr = (double)doublein(f);
- addr += sizeof(double);
- break;
- default:
- S_error1("", "unrecognized record fld type ~d", FIX(padty & 0xf));
- break;
- }
- }
-}
-
-/* limited version for checking rtd fields */
-static IBOOL equalp(ptr x, ptr y) {
- if (x == y) return 1;
- if (Spairp(x)) return Spairp(y) && equalp(Scar(x), Scar(y)) && equalp(Scdr(x), Scdr(y));
- if (Svectorp(x)) {
- iptr n;
- if (!Svectorp(y)) return 0;
- if ((n = Svector_length(x)) != Svector_length(y)) return 0;
- while (--n >= 0) if (!equalp(Svector_ref(x, n), Svector_ref(y, n))) return 0;
- return 1;
- }
- return Sbignump(x) && Sbignump(y) && S_big_eq(x, y);
-}
-
-static IBOOL rtd_equiv(ptr x, ptr y) {
- return RECORDINSTTYPE(x) == RECORDINSTTYPE(y) &&
- RECORDDESCPARENT(x) == RECORDDESCPARENT(y) &&
- equalp(RECORDDESCPM(x), RECORDDESCPM(y)) &&
- equalp(RECORDDESCMPM(x), RECORDDESCMPM(y)) &&
- equalp(RECORDDESCFLDS(x), RECORDDESCFLDS(y)) &&
- RECORDDESCSIZE(x) == RECORDDESCSIZE(y) &&
- RECORDDESCFLAGS(x) == RECORDDESCFLAGS(y);
-}
-
-#ifdef HPUX
-INT pax_decode21(INT x)
-{
- INT x0_4, x5_6, x7_8, x9_19, x20;
-
- x20 = x & 0x1; x >>= 1;
- x9_19 = x & 0x7ff; x >>= 11;
- x7_8 = x & 0x3; x >>= 2;
- x5_6 = x & 0x3;
- x0_4 = x >> 2;
-
- return (((x20<<11 | x9_19)<<2 | x5_6)<<5 | x0_4)<<2 | x7_8;
-}
-
-INT pax_encode21(INT n)
-{
- INT x0_4, x5_6, x7_8, x9_19, x20;
-
- x7_8 = n & 0x3; n >>= 2;
- x0_4 = n & 0x1f; n >>= 5;
- x5_6 = n & 0x3; n >>= 2;
- x9_19 = n & 0x7ff;
- x20 = n >> 11;
-
- return (((x0_4<<2 | x5_6)<<2 | x7_8)<<11 | x9_19)<<1 | x20;
-}
-#endif /* HPUX */
-
-/* used here, in S_gc(), and in compile.ss */
-void S_set_code_obj(char *who, IFASLCODE typ, ptr p, iptr n, ptr x, iptr o) {
- void *address; uptr item;
-
- address = (void *)((uptr)p + n);
- item = (uptr)x + o;
- switch (typ) {
- case reloc_abs:
- *(uptr *)address = item;
- break;
-#ifdef ARMV6
- case reloc_arm32_abs:
- arm32_set_abs(address, item);
- break;
- case reloc_arm32_jump:
- arm32_set_jump(address, item, 0);
- break;
- case reloc_arm32_call:
- arm32_set_jump(address, item, 1);
- break;
-#endif /* ARMV6 */
-#ifdef PPC32
- case reloc_ppc32_abs:
- ppc32_set_abs(address, item);
- break;
- case reloc_ppc32_jump:
- ppc32_set_jump(address, item, 0);
- break;
- case reloc_ppc32_call:
- ppc32_set_jump(address, item, 1);
- break;
-#endif /* PPC32 */
-#ifdef I386
- case reloc_rel:
- item = item - ((uptr)address + sizeof(uptr));
- *(uptr *)address = item;
- break;
-#endif /* I386 */
-#ifdef X86_64
- case reloc_x86_64_jump:
- x86_64_set_jump(address, item, 0);
- break;
- case reloc_x86_64_call:
- x86_64_set_jump(address, item, 1);
- break;
-#endif /* X86_64 */
-#ifdef SPARC64
- case reloc_sparc64abs:
- sparc64_set_literal(address, item);
- break;
- /* we don't use this presently since it can't handle out-of-range
- relocations */
- case reloc_sparc64rel:
- /* later: make the damn thing local by copying it an
- every other code object we can reach into a single
- close area of memory */
- item = item - (uptr)address;
- if ((iptr)item < -0x20000000 || (iptr)item > 0x1FFFFFFF)
- S_error1("", "sparc64rel address out of range ~x",
- Sunsigned((uptr)address));
- *(U32 *)address = *(U32 *)address & ~0x3fffffff | item >> 2 & 0x3fffffff;
- break;
-#endif /* SPARC64 */
-#ifdef SPARC
- case reloc_sparcabs:
- *(U32 *)address = *(U32 *)address & ~0x3fffff | item >> 10 & 0x3fffff;
- *((U32 *)address + 1) = *((U32 *)address + 1) & ~0x3ff | item & 0x3ff;
- break;
- case reloc_sparcrel:
- item = item - (uptr)address;
- *(U32 *)address = *(U32 *)address & ~0x3fffffff | item >> 2 & 0x3fffffff;
- break;
-#endif /* SPARC */
- default:
- S_error1(who, "invalid relocation type ~s", FIX(typ));
- }
-}
-
-/* used in S_gc() */
-ptr S_get_code_obj(IFASLCODE typ, ptr p, iptr n, iptr o) {
- void *address; uptr item;
-
- address = (void *)((uptr)p + n);
- switch (typ) {
- case reloc_abs:
- item = *(uptr *)address;
- break;
-#ifdef ARMV6
- case reloc_arm32_abs:
- item = arm32_get_abs(address);
- break;
- case reloc_arm32_jump:
- case reloc_arm32_call:
- item = arm32_get_jump(address);
- break;
-#endif /* ARMV6 */
-#ifdef PPC32
- case reloc_ppc32_abs:
- item = ppc32_get_abs(address);
- break;
- case reloc_ppc32_jump:
- case reloc_ppc32_call:
- item = ppc32_get_jump(address);
- break;
-#endif /* PPC32 */
-#ifdef I386
- case reloc_rel:
- item = *(uptr *)address;
- item = item + ((uptr)address + sizeof(uptr));
- break;
-#endif /* I386 */
-#ifdef X86_64
- case reloc_x86_64_jump:
- case reloc_x86_64_call:
- item = x86_64_get_jump(address);
- break;
-#endif /* X86_64 */
-#ifdef SPARC64
- case reloc_sparc64abs:
- item = sparc64_get_literal(address);
- break;
- case reloc_sparc64rel:
- item = (*(U32 *)address & 0x3fffffff) << 2;
- if (item & 0x80000000) /* sign bit set */
- item = item | 0xffffffff00000000;
- item = (uptr)address + (iptr)item;
- break;
-#endif /* SPARC64 */
-#ifdef SPARC
- case reloc_sparcabs:
- item = (*(U32 *)address & 0x3fffff) << 10 | *((U32 *)address + 1) & 0x3ff;
- break;
- case reloc_sparcrel:
- item = (*(U32 *)address & 0x3fffffff) << 2;
- item += (uptr)address;
- break;
-#endif /* SPARC */
- default:
- S_error1("", "invalid relocation type ~s", FIX(typ));
- return (ptr)0 /* not reached */;
- }
- return (ptr)(item - o);
-}
-
-
-#ifdef ARMV6
-static void arm32_set_abs(void *address, uptr item) {
- /* code generator produces ldrlit destreg, 0; brai 0; long 0 */
- /* we change long 0 => long item */
- *((U32 *)address + 2) = item;
-}
-
-static uptr arm32_get_abs(void *address) {
- return *((U32 *)address + 2);
-}
-
-#define MAKE_B(n) (0xEA000000 | (n))
-#define MAKE_BL(n) (0xEB000000 | (n))
-#define B_OR_BL_DISP(x) ((x) & 0xFFFFFF)
-#define MAKE_BX(reg) (0xE12FFF10 | (reg))
-#define MAKE_BLX(reg) (0xE12FFF30 | (reg))
-#define MAKE_LDRLIT(dst,n) (0xE59F0000 | ((dst) << 12) | (n))
-#define LDRLITP(x) (((x) & 0xFFFF0000) == 0xE59F0000)
-#define LDRLIT_DST(x) (((x) >> 12) & 0xf)
-#define MAKE_MOV(dst,src) (0xE1A00000 | ((dst) << 12) | (src))
-#define MOV_SRC(x) ((x) & 0xf)
-/* nop instruction is not supported by all ARMv6 chips, so use recommended mov r0, r0 */
-#define NOP MAKE_MOV(0,0)
-
-static void arm32_set_jump(void *address, uptr item, IBOOL callp) {
- /* code generator produces ldrlit %ip, 0; brai 0; long 0; bx or blx %ip */
- U32 inst = *((U32 *)address + 0);
- INT reg = LDRLITP(inst) ? LDRLIT_DST(inst) : MOV_SRC(*((U32 *)address + 1));
- I32 worddisp = (U32 *)item - ((U32 *)address + 2);
- if (worddisp >= -0x800000 && worddisp <= 0x7FFFFF) {
- worddisp &= 0xFFFFFF;
- *((U32 *)address + 0) = (callp ? MAKE_BL(worddisp) : MAKE_B(worddisp));
- *((U32 *)address + 1) = MAKE_MOV(reg,reg); /* effective NOP recording tmp reg for later use */
- *((U32 *)address + 2) = NOP;
- *((U32 *)address + 3) = NOP;
- } else {
- *((U32 *)address + 0) = MAKE_LDRLIT(reg,0);
- *((U32 *)address + 1) = MAKE_B(0);
- *((U32 *)address + 2) = item;
- *((U32 *)address + 3) = (callp ? MAKE_BLX(reg) : MAKE_BX(reg));
- }
-}
-
-static uptr arm32_get_jump(void *address) {
- U32 inst = *((U32 *)address + 0);
- if (LDRLITP(inst)) {
- return *((U32 *)address + 2);
- } else {
- I32 worddisp = B_OR_BL_DISP(inst);
- if (worddisp >= 0x800000) worddisp -= 0x1000000;
- return (uptr)(((U32 *)address + 2) + worddisp);
- }
-}
-#endif /* ARMV6 */
-
-#ifdef PPC32
-
-#define UPDATE_ADDIS(item, instr) (((instr) & ~0xFFFF) | (((item) >> 16) & 0xFFFF))
-#define UPDATE_ADDI(item, instr) (((instr) & ~0xFFFF) | ((item) & 0xFFFF))
-
-#define MAKE_B(disp, callp) ((18 << 26) | (((disp) & 0xFFFFFF) << 2) | (callp))
-#define MAKE_ADDIS(item) ((15 << 26) | (((item) >> 16) & 0xFFFF))
-#define MAKE_ORI(item) ((24 << 26) | ((item) & 0xFFFF))
-#define MAKE_NOP ((24 << 26))
-#define MAKE_MTCTR ((31 << 26) | (9 << 16) | (467 << 1))
-#define MAKE_BCTR(callp) ((19 << 26) | (20 << 21) | (528 << 1) | (callp))
-
-static void ppc32_set_abs(void *address, uptr item) {
- /* code generator produces addis destreg, %r0, 0 (hi) ; addi destreg, destreg, 0 (lo) */
- /* we change 0 (hi) => upper 16 bits of address */
- /* we change 0 (lo) => lower 16 bits of address */
- /* low part is signed: if negative, increment high part */
- item = item + (item << 1 & 0x10000);
- *((U32 *)address + 0) = UPDATE_ADDIS(item, *((U32 *)address + 0));
- *((U32 *)address + 1) = UPDATE_ADDI(item, *((U32 *)address + 1));
-}
-
-static uptr ppc32_get_abs(void *address) {
- uptr item = ((*((U32 *)address + 0) & 0xFFFF) << 16) | (*((U32 *)address + 1) & 0xFFFF);
- return item - (item << 1 & 0x10000);
-}
-
-static void ppc32_set_jump(void *address, uptr item, IBOOL callp) {
- iptr disp = (iptr *)item - (iptr *)address;
- if (-0x800000 <= disp && disp <= 0x7FFFFF) {
- *((U32 *)address + 0) = MAKE_B(disp, callp);
- *((U32 *)address + 1) = MAKE_NOP;
- *((U32 *)address + 2) = MAKE_NOP;
- *((U32 *)address + 3) = MAKE_NOP;
- } else {
- *((U32 *)address + 0) = MAKE_ADDIS(item);
- *((U32 *)address + 1) = MAKE_ORI(item);
- *((U32 *)address + 2) = MAKE_MTCTR;
- *((U32 *)address + 3) = MAKE_BCTR(callp);
- }
-}
-
-static uptr ppc32_get_jump(void *address) {
- uptr item, instr = *(U32 *)address;
-
- if ((instr >> 26) == 18) {
- /* bl disp */
- iptr disp = (instr >> 2) & 0xFFFFFF;
- if (disp & 0x800000) disp -= 0x1000000;
- item = (uptr)address + (disp << 2);
- } else {
- /* lis r0, high
- ori r0, r0, low */
- item = ((instr & 0xFFFF) << 16) | (*((U32 *)address + 1) & 0xFFFF);
- }
-
- return item;
-}
-#endif /* PPC32 */
-
-#ifdef X86_64
-static void x86_64_set_jump(void *address, uptr item, IBOOL callp) {
- I64 disp = (I64)item - ((I64)address + 5); /* 5 = size of call instruction */
- if ((I32)disp == disp) {
- *(octet *)address = callp ? 0xE8 : 0xE9; /* call or jmp disp32 opcode */
- *(I32 *)((uptr)address + 1) = (I32)disp;
- /* 7-byte long NOP */
- *((octet *)address + 5) = 0x0f;
- *((octet *)address + 6) = 0x1f;
- *((octet *)address + 7) = 0x80;
- *((octet *)address + 8) = 0x00;
- *((octet *)address + 9) = 0x00;
- *((octet *)address + 10) = 0x00;
- *((octet *)address + 11) = 0x00;
- } else {
- *(octet *)address = 0x48; /* REX w/REX.w set */
- *((octet *)address + 1)= 0xB8; /* MOV imm64 to RAX */
- *(uptr *)((uptr)address + 2) = item;
- *((octet *)address + 10) = 0xFF; /* call/jmp reg/mem opcode */
- *((octet *)address + 11) = callp ? 0xD0 : 0xE0; /* mod=11, ttt=010 (call) or 100 (jmp), r/m = 0 (RAX) */
- }
-}
-
-static uptr x86_64_get_jump(void *address) {
- if (*(octet *)address == 0x48) /* REX w/REX.w set */
- /* must be long form: move followed by call/jmp */
- return *(uptr *)((uptr)address + 2);
- else
- /* must be short form: call/jmp */
- return ((uptr)address + 5) + *(I32 *)((uptr)address + 1);
-}
-#endif /* X86_64 */
-
-#ifdef SPARC64
-#define ASMREG0 1
-/* TMPREG is asm-literal-tmp in sparc64macros.ss */
-#define TMPREG 5
-/* CRETREG is retreg in sparc64macros.ss */
-#define CRETREG 15
-/* SRETREG is ret in sparc64macros.ss */
-#define SRETREG 26
-
-#define OP_ADDI 0x80002000
-#define OP_CALL 0x40000000
-#define OP_JSR 0x81C00000
-#define OP_OR 0x80100000
-#define OP_ORI 0x80102000
-#define OP_SETHI 0x1000000
-/* SLLXI is the 64-bit version */
-#define OP_SLLXI 0x81283000
-#define OP_XORI 0x80182000
-/* NOP is sethi %g0,0 */
-#define NOP 0x1000000
-#define IMMMASK (U32)0x1fff
-#define IMMRANGE(x) ((U32)(x) + (U32)0x1000 <= IMMMASK)
-#define ADDI(src,imm,dst) (OP_ADDI | (dst) << 25 | (src) << 14 | (imm) & IMMMASK)
-#define JSR(src) (OP_JSR | CRETREG << 25 | (src) << 14)
-#define ORI(src,imm,dst) (OP_ORI | (dst) << 25 | (src) << 14 | (imm) & IMMMASK)
-#define SETHI(dst,high) (OP_SETHI | (dst) << 25 | (high) & 0x3fffff)
-#define CALL(disp) (OP_CALL | (disp) >> 2 & 0x3fffffff)
-
-
-static INT extract_reg_from_sethi(void* address) {
- return *(U32 *)address >> 25;
-}
-
-static void emit_sethi_lo(U32 item, INT destreg, void *address) {
- U32 high = item >> 10;
- U32 low = item & 0x3ff;
-
- /* sethi destreg, high */
- *(U32 *)address = SETHI(destreg,high);
- /* setlo destreg, low */
- *((U32 *)address + 1) = ORI(destreg,low,destreg);
-}
-
-static uptr sparc64_get_literal(void *address) {
- uptr item;
-
- /* we may have "call disp" followed by delay instruction */
- item = *(U32 *)address;
- if (item >> 30 == OP_CALL >> 30) {
- item = (item & 0x3fffffff) << 2;
- if (item & 0x80000000) /* sign bit set */
- item = item | 0xffffffff00000000;
- item = (uptr)address + (iptr)item;
- return item;
- }
-
- item = (item & 0x3fffff) << 10 | *((U32 *)address + 1) & 0x3ff;
- if (*((U32 *)address + 2) != NOP) {
- item = item << 32 |
- (*((U32 *)address + 3) & 0x3fffff) << 10 |
- *((U32 *)address + 4) & 0x3ff;
- }
- return item;
-}
-
-static U32 adjust_delay_inst(delay_inst, old_call_addr, new_call_addr)
- U32 delay_inst; U32 *old_call_addr, *new_call_addr; {
- INT offset;
-
- offset = sizeof(U32) * (old_call_addr - new_call_addr);
- if (offset == 0) return delay_inst;
-
- if ((delay_inst & ~IMMMASK) == ADDI(CRETREG,0,SRETREG)) {
- INT k = delay_inst & IMMMASK;
- k = k - ((k << 1) & (IMMMASK+1));
- offset = k + offset;
- if (IMMRANGE(offset)) return ADDI(CRETREG,offset,SRETREG);
- } else if ((delay_inst & ~IMMMASK) == ADDI(CRETREG,0,CRETREG)) {
- INT k = delay_inst & IMMMASK;
- k = k - ((k << 1) & (IMMMASK+1));
- offset = k + offset;
- if (offset == 0) return NOP;
- if (IMMRANGE(offset)) return ADDI(CRETREG,offset,CRETREG);
- } else if (IMMRANGE(offset))
- return ADDI(CRETREG,offset,CRETREG);
-
- return 0; /* fortunately, not a valid instruction here */
-}
-
-static void sparc64_set_call(void *address, U32 *call_addr, uptr item) {
- U32 delay_inst = *(call_addr + 1), new_delay_inst; iptr disp;
-
- /* later: make item local if it refers to Scheme code, i.e., is in the
- Scheme heap, by copying it and every other code object we can reach
- into a single close area of memory. Or generate a close stub. */
- disp = item - (uptr)address;
- if (disp >= -0x20000000 && disp <= 0x1FFFFFFF &&
- (new_delay_inst = adjust_delay_inst(delay_inst, call_addr,
- (U32 *)address))) {
- *(U32 *)address = CALL(disp);
- *((U32 *)address + 1) = new_delay_inst;
- } else {
- INT n = sparc64_set_lit_only(address, item, ASMREG0);
- new_delay_inst = adjust_delay_inst(delay_inst, call_addr, (U32 *)address + n);
- *((U32 *)address + n) = JSR(ASMREG0);
- *((U32 *)address + n + 1) = new_delay_inst;
- }
-}
-
-static INT sparc64_set_lit_only(void *address, uptr item, I32 destreg) {
-
- if ((iptr)item >= -0xffffffff && item <= 0xffffffff) {
- uptr x, high, low;
-
- if ((iptr)item < 0) {
- x = 0x100000000 - item;
- high = x >> 10;
- low = x - (high << 10);
- /* sethi destreg, ~high */
- *(U32 *)address = OP_SETHI | destreg << 25 | ~high & 0x3fffff;
- /* xor.i destreg, low|0x1c00, destreg */
- *((U32 *)address + 1) = OP_XORI | destreg << 25 | destreg << 14 |
- low | 0x1c00;
- } else {
- emit_sethi_lo(item, destreg, address);
- }
- *((U32 *)address + 2) = NOP;
- *((U32 *)address + 3) = NOP;
- *((U32 *)address + 4) = NOP;
- *((U32 *)address + 5) = NOP;
- return 2;
- } else {
- emit_sethi_lo(item >> 32, destreg, address);
- /* sll destreg, 32, destreg */
- *((U32 *)address + 2) = OP_SLLXI | destreg << 25 | destreg << 14 | 32;
- emit_sethi_lo(item & 0xffffffff, TMPREG, (void *)((U32 *)address+3));
- /* or destreg, tmpreg, destreg */
- *((U32 *)address + 5) = OP_OR | destreg << 25 | destreg << 14 | TMPREG;
- return 6;
- }
-}
-
-static void sparc64_set_literal(void* address, uptr item) {
- I32 destreg;
-
- /* case 1: we have call followed by delay inst */
- if (*(U32 *)address >> 30 == OP_CALL >> 30) {
- sparc64_set_call(address, (U32 *)address, item);
- return;
- }
-
- destreg = extract_reg_from_sethi(address);
-
- /* case 2: we have two-instr load-literal followed by jsr and delay inst */
- if (*((U32 *)address + 2) == JSR(destreg)) {
- sparc64_set_call(address, (U32 *)address + 2, item);
- return;
- }
-
- /* case 3: we have six-instr load-literal followed by jsr and a delay
- instruction we're willing to try to deal with */
- if (*((U32 *)address + 6) == JSR(destreg) &&
- (*((U32 *)address + 7) & ~IMMMASK == ADDI(CRETREG,0,SRETREG) ||
- *((U32 *)address + 7) == NOP)) {
- sparc64_set_call(address, (U32 *)address + 6, item);
- return;
- }
-
- /* case 4: we have a plain load-literal */
- sparc64_set_lit_only(address, item, destreg);
-}
-#endif /* SPARC64 */
diff --git a/ta6ob/c/fasl.o b/ta6ob/c/fasl.o
deleted file mode 100644
index b1c7d97..0000000
Binary files a/ta6ob/c/fasl.o and /dev/null differ
diff --git a/ta6ob/c/flushcache.c b/ta6ob/c/flushcache.c
deleted file mode 100644
index e2520f9..0000000
--- a/ta6ob/c/flushcache.c
+++ /dev/null
@@ -1,87 +0,0 @@
-/* flushcache.c
- * Copyright 1984-2017 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.
- */
-
-#include "system.h"
-
-#ifdef FLUSHCACHE
-typedef struct {
- uptr start;
- uptr end;
-} mod_range;
-
-#define mod_range_start(x) (((mod_range *)&BVIT(x,0))->start)
-#define mod_range_end(x) (((mod_range *)&BVIT(x,0))->end)
-
-static uptr max_gap;
-
-static ptr make_mod_range(uptr start, uptr end) {
- ptr bv = S_bytevector(sizeof(mod_range));
- mod_range_start(bv) = start;
- mod_range_end(bv) = end;
- return bv;
-}
-
-/* we record info per thread so flush in one prematurely for another doesn't prevent
- the other from doing its own flush...and also since it's not clear that flushing in one
- actually syncs caches across cores & processors */
-
-void S_record_code_mod(ptr tc, uptr addr, uptr bytes) {
- uptr end = addr + bytes;
- ptr ls = CODERANGESTOFLUSH(tc);
-
- if (ls != Snil) {
- ptr last_mod = Scar(ls);
- uptr last_end = mod_range_end(last_mod);
- if (addr > last_end && addr - last_end < max_gap) {
-#ifdef DEBUG
- printf(" record_code_mod merging %x %x and %x %x\n", mod_range_start(last_mod), last_end, addr, end); fflush(stdout);
-#endif
- mod_range_end(last_mod) = end;
- return;
- }
- }
-
-#ifdef DEBUG
- printf(" record_code_mod new range %x to %x\n", addr, end); fflush(stdout);
-#endif
- CODERANGESTOFLUSH(tc) = S_cons_in(space_new, 0, make_mod_range(addr, end), ls);
- return;
-}
-
-extern void S_flush_instruction_cache(ptr tc) {
- ptr ls;
-
- for (ls = CODERANGESTOFLUSH(tc); ls != Snil; ls = Scdr(ls)) {
- S_doflush(mod_range_start(Scar(ls)), mod_range_end(Scar(ls)));
- }
- CODERANGESTOFLUSH(tc) = Snil;
-}
-
-extern void S_flushcache_init(void) {
- if (S_boot_time) {
- max_gap = S_flushcache_max_gap();
- if (max_gap < (uptr)(code_data_disp + byte_alignment)) {
- max_gap = (uptr)(code_data_disp + byte_alignment);
- }
- }
-}
-#else /* FLUSHCACHE */
-
-extern void S_record_code_mod(UNUSED ptr tc, UNUSED uptr addr, UNUSED uptr bytes) {}
-extern void S_flush_instruction_cache(UNUSED ptr tc) {}
-extern void S_flushcache_init(void) { return; }
-
-#endif /* FLUSHCACHE */
diff --git a/ta6ob/c/flushcache.o b/ta6ob/c/flushcache.o
deleted file mode 100644
index 19d08f1..0000000
Binary files a/ta6ob/c/flushcache.o and /dev/null differ
diff --git a/ta6ob/c/foreign.c b/ta6ob/c/foreign.c
deleted file mode 100644
index fbe9a12..0000000
--- a/ta6ob/c/foreign.c
+++ /dev/null
@@ -1,334 +0,0 @@
-/* foreign.c
- * Copyright 1984-2017 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 debug(y) /* (void)printf(y) *//* uncomment printf for debug */
-/* #define UNLINK(x) 0 *//* uncomment #define to preserve temp files */
-
-
-#include "system.h"
-
-/* we can now return arbitrary values (aligned or not)
- * since the garbage collector ignores addresses outside of the heap
- * or within foreign segments */
-#define ptr_to_addr(p) ((void *)p)
-#define addr_to_ptr(a) ((ptr)a)
-
-/* buckets should be prime */
-#define buckets 457
-#define multiplier 3
-
-#define ptrhash(x) ((uptr)x % buckets)
-
-#ifdef LOAD_SHARED_OBJECT
-#if defined(HPUX)
-#include
-#define dlopen(path,flags) (void *)shl_load(path, BIND_IMMEDIATE, 0L)
-#define s_dlerror() Sstring_utf8(strerror(errno), -1)
-#elif defined(WIN32)
-#define dlopen(path,flags) S_ntdlopen(path)
-#define dlsym(h,s) S_ntdlsym(h,s)
-#define s_dlerror() S_ntdlerror()
-#else
-#include
-#define s_dlerror() Sstring_utf8(dlerror(), -1)
-#ifndef RTLD_NOW
-#define RTLD_NOW 2
-#endif /* RTLD_NOW */
-#endif /* machine types */
-#endif /* LOAD_SHARED_OBJECT */
-
-/* locally defined functions */
-static uptr symhash(const char *s);
-static ptr lookup_static(const char *s);
-static ptr lookup_dynamic(const char *s, ptr tbl);
-static ptr lookup(const char *s);
-static ptr remove_foreign_entry(const char *s);
-static void *lookup_foreign_entry(const char *s);
-static ptr foreign_entries(void);
-static ptr foreign_static_table(void);
-static ptr foreign_dynamic_table(void);
-static ptr bvstring(const char *s);
-
-#ifdef LOAD_SHARED_OBJECT
-static void load_shared_object(const char *path);
-#endif /* LOAD_SHARED_OBJECT */
-
-#ifdef HPUX
-void *proc2entry(void *f, ptr name) {
- if (((uptr)f & 2) == 0)
- if (name == NULL)
- S_error("Sforeign_symbol", "invalid entry");
- else
- S_error1("Sforeign_symbol", "invalid entry for ~s", name);
- return (void *)((uptr)f & ~0x3);
-}
-#endif /* HPUX */
-
-static ptr bvstring(const char *s) {
- iptr n = strlen(s) + 1;
- ptr x = S_bytevector(n);
- memcpy(&BVIT(x, 0), s, n);
- return x;
-}
-
-/* multiplier weights each character, h = n factors in the length */
-static uptr symhash(const char *s) {
- uptr n, h;
-
- h = n = strlen(s);
- while (n--) h = h * multiplier + (unsigned char)*s++;
- return h % buckets;
-}
-
-static ptr lookup_static(const char *s) {
- uptr b; ptr p;
-
- b = symhash(s);
- for (p = Svector_ref(S_G.foreign_static, b); p != Snil; p = Scdr(p))
- if (strcmp(s, (char *)&BVIT(Scar(Scar(p)),0)) == 0)
- return Scdr(Scar(p));
-
- return addr_to_ptr(0);
-}
-
-#ifdef LOAD_SHARED_OBJECT
-#define LOOKUP_DYNAMIC
-static ptr lookup_dynamic(const char *s, ptr tbl) {
- ptr p;
-
- for (p = tbl; p != Snil; p = Scdr(p)) {
-#ifdef HPUX
- (void *)value = (void *)0; /* assignment to prevent compiler warning */
- shl_t handle = (shl_t)ptr_to_addr(Scar(p));
-
- if (shl_findsym(&handle, s, TYPE_PROCEDURE, (void *)&value) == 0)
- return addr_to_ptr(proc2entry(value, NULL));
-#else /* HPUX */
- void *value;
-
- value = dlsym(ptr_to_addr(Scar(p)), s);
- if (value != (void *)0) return addr_to_ptr(value);
-#endif /* HPUX */
- }
-
- return addr_to_ptr(0);
-}
-#endif /* LOAD_SHARED_OBJECT */
-
-static ptr lookup(const char *s) {
- iptr b; ptr p;
-
-#ifdef LOOKUP_DYNAMIC
- ptr x;
-
- x = lookup_dynamic(s, S_foreign_dynamic);
- if (x == addr_to_ptr(0))
-#endif /* LOOKUP_DYNAMIC */
-
- x = lookup_static(s);
- if (x == addr_to_ptr(0)) return x;
-
- tc_mutex_acquire()
-
- b = ptrhash(x);
- for (p = Svector_ref(S_G.foreign_names, b); p != Snil; p = Scdr(p)) {
- if (Scar(Scar(p)) == x) {
- SETCDR(Scar(p),bvstring(s));
- goto quit;
- }
- }
- SETVECTIT(S_G.foreign_names, b, Scons(Scons(addr_to_ptr(x),bvstring(s)),
- Svector_ref(S_G.foreign_names, b)));
-
-quit:
- tc_mutex_release()
- return x;
-}
-
-void Sforeign_symbol(const char *s, void *v) {
- iptr b; ptr x;
-
- tc_mutex_acquire()
-
-#ifdef HPUX
- v = proc2entry(v,name);
-#endif
-
- if ((x = lookup(s)) == addr_to_ptr(0)) {
- b = symhash(s);
- SETVECTIT(S_G.foreign_static, b, Scons(Scons(bvstring(s), addr_to_ptr(v)),
- Svector_ref(S_G.foreign_static, b)));
- } else if (ptr_to_addr(x) != v)
- S_error1("Sforeign_symbol", "duplicate symbol entry for ~s", Sstring_utf8(s, -1));
-
- tc_mutex_release()
-}
-
-/* like Sforeign_symbol except it silently redefines the symbol
- if it's already in S_G.foreign_static */
-void Sregister_symbol(const char *s, void *v) {
- uptr b; ptr p;
-
- tc_mutex_acquire()
-
- b = symhash(s);
- for (p = Svector_ref(S_G.foreign_static, b); p != Snil; p = Scdr(p))
- if (strcmp(s, (char *)&BVIT(Scar(Scar(p)),0)) == 0) {
- INITCDR(Scar(p)) = addr_to_ptr(v);
- goto quit;
- }
- SETVECTIT(S_G.foreign_static, b, Scons(Scons(bvstring(s), addr_to_ptr(v)),
- Svector_ref(S_G.foreign_static, b)));
-
- quit:
- tc_mutex_release()
-}
-
-static ptr remove_foreign_entry(const char *s) {
- uptr b;
- ptr tbl, p1, p2;
-
- tc_mutex_acquire()
-
- b = symhash(s);
- tbl = S_G.foreign_static;
- p1 = Snil;
- p2 = Svector_ref(tbl, b);
- for (; p2 != Snil; p1 = p2, p2 = Scdr(p2)) {
- if (strcmp(s, (char *)&BVIT(Scar(Scar(p2)), 0)) == 0) {
- if (p1 == Snil) {
- SETVECTIT(tbl, b, Scdr(p2))
- } else {
- SETCDR(p1, Scdr(p2))
- }
- tc_mutex_release()
- return Strue;
- }
- }
- tc_mutex_release()
- return Sfalse;
-}
-
-#ifdef LOAD_SHARED_OBJECT
-static void load_shared_object(const char *path) {
- void *handle;
-
- tc_mutex_acquire()
-
- handle = dlopen(path, RTLD_NOW);
- if (handle == (void *)NULL)
- S_error2("", "(while loading ~a) ~a", Sstring_utf8(path, -1), s_dlerror());
- S_foreign_dynamic = Scons(addr_to_ptr(handle), S_foreign_dynamic);
-
- tc_mutex_release()
-
- return;
-}
-#endif /* LOAD_SHARED_OBJECT */
-
-void S_foreign_entry(void) {
- ptr tc = get_thread_context();
- ptr name, x, bvname;
- iptr i, n;
-
- name = AC0(tc);
- if (Sfixnump(name) || Sbignump(name)) {
- AC0(tc) = (ptr)Sinteger_value(name);
- return;
- }
-
- if (!(Sstringp(name))) {
- S_error1("foreign-procedure", "invalid foreign procedure handle ~s", name);
- }
-
- n = Sstring_length(name);
- bvname = S_bytevector(n + 1);
- for (i = 0; i != n; i += 1) {
- int k = Sstring_ref(name, i);
- if (k >= 256) k = '?';
- BVIT(bvname, i) = k;
- }
- BVIT(bvname, n) = 0;
-
- if ((x = lookup((char *)&BVIT(bvname, 0))) == addr_to_ptr(0)) {
- S_error1("foreign-procedure", "no entry for ~s", name);
- }
-
- AC0(tc) = x;
-}
-
-static void *lookup_foreign_entry(s) const char *s; {
- return ptr_to_addr(lookup(s));
-}
-
-static ptr foreign_entries(void) {
- iptr b; ptr p, entries;
-
- entries = Snil;
-
- for (b = 0; b < buckets; b++)
- for (p = Svector_ref(S_G.foreign_static, b); p != Snil; p = Scdr(p))
- entries = Scons(Sstring_utf8((char *)&BVIT(Scar(Scar(p)), 0), -1), entries);
-
- return entries;
-}
-
-static ptr foreign_static_table(void) { return S_G.foreign_static; }
-#ifdef LOAD_SHARED_OBJECT
-static ptr foreign_dynamic_table(void) { return S_foreign_dynamic; }
-#else
-static ptr foreign_dynamic_table(void) { return Sfalse; }
-#endif /* LOAD_SHARED_OBJECT */
-
-static octet *foreign_address_name(ptr addr) {
- iptr b; ptr p;
-
- b = ptrhash(addr);
- for (p = Svector_ref(S_G.foreign_names, b); p != Snil; p = Scdr(p))
- if (Scar(Scar(p)) == (ptr)addr)
- return &BVIT(Scdr(Scar(p)),0);
-
- return NULL;
-}
-
-void S_foreign_init(void) {
- if (S_boot_time) {
- S_protect(&S_G.foreign_static);
- S_G.foreign_static = S_vector(buckets);
- {iptr i; for (i = 0; i < buckets; i++) INITVECTIT(S_G.foreign_static,i) = Snil;}
-
- S_protect(&S_G.foreign_names);
- S_G.foreign_names = S_vector(buckets);
- {iptr i; for (i = 0; i < buckets; i++) INITVECTIT(S_G.foreign_names,i) = Snil;}
-
-#ifdef LOAD_SHARED_OBJECT
- S_protect(&S_foreign_dynamic);
- S_foreign_dynamic = Snil;
- Sforeign_symbol("(cs)load_shared_object", (void *)load_shared_object);
-#endif /* LOAD_SHARED_OBJECT */
-
- Sforeign_symbol("(cs)lookup_foreign_entry", (void *)lookup_foreign_entry);
- Sforeign_symbol("(cs)remove_foreign_entry", (void *)remove_foreign_entry);
- Sforeign_symbol("(cs)foreign_entries", (void *)foreign_entries);
- Sforeign_symbol("(cs)foreign_static_table", (void *)foreign_static_table);
- Sforeign_symbol("(cs)foreign_dynamic_table", (void *)foreign_dynamic_table);
- Sforeign_symbol("(cs)foreign_address_name", (void *)foreign_address_name);
- }
-
-#ifdef LOAD_SHARED_OBJECT
- S_foreign_dynamic = Snil;
-#endif /* LOAD_SHARED_OBJECT */
-}
diff --git a/ta6ob/c/foreign.o b/ta6ob/c/foreign.o
deleted file mode 100644
index b95ce74..0000000
Binary files a/ta6ob/c/foreign.o and /dev/null differ
diff --git a/ta6ob/c/gc-011.c b/ta6ob/c/gc-011.c
deleted file mode 100644
index 5fbbbef..0000000
--- a/ta6ob/c/gc-011.c
+++ /dev/null
@@ -1,23 +0,0 @@
-/* gc-011.c
- * Copyright 1984-2020 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 GCENTRY S_gc_011
-#define MAX_CG 0
-#define MIN_TG 1
-#define MAX_TG 1
-#define compute_target_generation(g) 1
-#define NO_LOCKED_OLDSPACE_OBJECTS
-#include "gc.c"
diff --git a/ta6ob/c/gc-011.o b/ta6ob/c/gc-011.o
deleted file mode 100644
index 25995cc..0000000
Binary files a/ta6ob/c/gc-011.o and /dev/null differ
diff --git a/ta6ob/c/gc-ocd.c b/ta6ob/c/gc-ocd.c
deleted file mode 100644
index 614d4fa..0000000
--- a/ta6ob/c/gc-ocd.c
+++ /dev/null
@@ -1,18 +0,0 @@
-/* gc-ocd.c
- * Copyright 1984-2017 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 GCENTRY S_gc_ocd
-#include "gc.c"
diff --git a/ta6ob/c/gc-ocd.o b/ta6ob/c/gc-ocd.o
deleted file mode 100644
index 7a55b73..0000000
Binary files a/ta6ob/c/gc-ocd.o and /dev/null differ
diff --git a/ta6ob/c/gc-oce.c b/ta6ob/c/gc-oce.c
deleted file mode 100644
index ab910e7..0000000
--- a/ta6ob/c/gc-oce.c
+++ /dev/null
@@ -1,19 +0,0 @@
-/* gc-oce.c
- * Copyright 1984-2017 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 GCENTRY S_gc_oce
-#define ENABLE_OBJECT_COUNTS
-#include "gc.c"
diff --git a/ta6ob/c/gc-oce.o b/ta6ob/c/gc-oce.o
deleted file mode 100644
index e447b2f..0000000
Binary files a/ta6ob/c/gc-oce.o and /dev/null differ
diff --git a/ta6ob/c/gc.c b/ta6ob/c/gc.c
deleted file mode 100644
index 425d92f..0000000
--- a/ta6ob/c/gc.c
+++ /dev/null
@@ -1,2324 +0,0 @@
-/* gc.c
- * Copyright 1984-2017 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.
- */
-
-#include "system.h"
-#include "sort.h"
-#ifndef WIN32
-#include
-#endif /* WIN32 */
-
-#define enable_object_counts do_not_use_enable_object_counts_in_this_file_use_ifdef_ENABLE_OBJECT_COUNTS_instead
-
-#if defined(MIN_TG) && defined(MAX_TG)
-#if MIN_TG == MAX_TG
-#define NO_DIRTY_NEWSPACE_POINTERS
-#endif
-#endif
-
-#if defined(MAX_CG) && defined(MIN_TG) && defined(MAX_TG)
-#define FORMAL_CTGS
-#define ONLY_FORMAL_CTGS void
-#define ACTUAL_CTGS
-#define ONLY_ACTUAL_CTGS
-#define DECLARE_CTGS(max_cg, min_tg, max_tg) IGEN max_cg = MAX_CG, min_tg = MIN_TG, max_tg = MAX_TG
-#define GCENTRY_PROTO(tcdecl, max_cgdecl, min_tgdecl, max_tgdecl) (tcdecl)
-#else
-#define FORMAL_CTGS , UINT _ctgs
-#define ONLY_FORMAL_CTGS UINT _ctgs
-#define ACTUAL_CTGS , _ctgs
-#define ONLY_ACTUAL_CTGS _ctgs
-#define DECLARE_CTGS(max_cg, min_tg, max_tg) UINT _ctgs = (((UINT)min_tg << 16) | ((UINT)max_cg << 8) | (UINT)max_tg)
-#define MAX_CG ((INT)((_ctgs >> 8) & 0xff))
-#define MIN_TG ((INT)(_ctgs >> 16))
-#define MAX_TG ((INT)(_ctgs & 0xff))
-#define GCENTRY_PROTO(tcdecl, max_cgdecl, min_tgdecl, max_tgdecl) (tcdecl, max_cgdecl, min_tgdecl, max_tgdecl)
-#endif
-
-/* locally defined functions */
-#ifndef NO_DIRTY_NEWSPACE_POINTERS
-static void record_new_dirty_card(ptr *ppp, IGEN to_g);
-#endif /* !NO_DIRTY_NEWSPACE_POINTERS */
-#ifndef NO_LOCKED_OLDSPACE_OBJECTS
-static ptr append_bang(ptr ls1, ptr ls2);
-static uptr count_unique(ptr ls);
-static uptr list_length(ptr ls);
-static ptr dosort(ptr ls, uptr n);
-static ptr domerge(ptr l1, ptr l2);
-static IBOOL search_locked(ptr p);
-#endif /* !NO_LOCKED_OLDSPACE_OBJECTS */
-static IGEN copy(ptr pp, seginfo *si, ptr *ppp FORMAL_CTGS);
-static void sweep_locked_ptrs(ptr *p, iptr n FORMAL_CTGS);
-static void sweep_locked(ptr tc, ptr p, IBOOL sweep_pure FORMAL_CTGS);
-static ptr copy_stack(ptr old, iptr *length, iptr clength FORMAL_CTGS);
-static void resweep_weak_pairs(ONLY_FORMAL_CTGS);
-static void forward_or_bwp(ptr *pp, ptr p);
-static void sweep_generation(ptr tc FORMAL_CTGS);
-#ifndef NO_LOCKED_OLDSPACE_OBJECTS
-static iptr size_object(ptr p);
-#endif /* !NO_LOCKED_OLDSPACE_OBJECTS */
-static iptr sweep_typed_object(ptr p, IGEN from_g FORMAL_CTGS);
-static void sweep_symbol(ptr p, IGEN from_g FORMAL_CTGS);
-static void sweep_port(ptr p, IGEN from_g FORMAL_CTGS);
-static void sweep_thread(ptr p FORMAL_CTGS);
-static void sweep_continuation(ptr p FORMAL_CTGS);
-static void sweep_stack(uptr base, uptr size, uptr ret FORMAL_CTGS);
-static void sweep_record(ptr x, IGEN from_g FORMAL_CTGS);
-static IGEN sweep_dirty_record(ptr x, IGEN youngest FORMAL_CTGS);
-static void sweep_code_object(ptr tc, ptr co FORMAL_CTGS);
-static void record_dirty_segment(IGEN from_g, IGEN to_g, seginfo *si);
-static void sweep_dirty(ONLY_FORMAL_CTGS);
-static void resweep_dirty_weak_pairs(ONLY_FORMAL_CTGS);
-static void add_ephemeron_to_pending(ptr p);
-static void add_trigger_ephemerons_to_repending(ptr p);
-static void check_trigger_ephemerons(seginfo *si);
-static void check_ephemeron(ptr pe, IBOOL add_to_trigger FORMAL_CTGS);
-static void check_pending_ephemerons(ONLY_FORMAL_CTGS);
-static IGEN check_dirty_ephemeron(ptr pe, IGEN youngest FORMAL_CTGS);
-static void clear_trigger_ephemerons();
-
-#define OLDSPACE(x) (SPACE(x) & space_old)
-
-/* #define DEBUG */
-
-/* initialized and used each gc cycle. any others should be defined in globals.h */
-static IBOOL change;
-static ptr sweep_loc[static_generation+1][max_real_space+1];
-static ptr orig_next_loc[static_generation+1][max_real_space+1];
-#ifndef NO_LOCKED_OLDSPACE_OBJECTS
-static ptr sorted_locked_objects;
-#endif /* !NO_LOCKED_OLDSPACE_OBJECTS */
-static ptr tlcs_to_rehash;
-
-#ifndef compute_target_generation
-FORCEINLINE IGEN compute_target_generation(IGEN g FORMAL_CTGS) {
- return g == MAX_TG ? g : g < MIN_TG ? MIN_TG : g + 1;
-}
-#endif /* !compute_target_generation */
-
-/* rkd 2020/06/16: had the relocate routines more nicely coded with FORCEINLINE.
- unfortunately, the llvm-compiled gc ran much (10-20%) slower on my mac. */
-#define relocate_return_addr(PCP) do {\
- ptr *_pcp = PCP;\
- seginfo *_si;\
- ptr _cp = *_pcp;\
- if ((_si = SegInfo(ptr_get_segment(_cp)))->space & space_old) {\
- iptr _co = ENTRYOFFSET(_cp) + ((uptr)_cp - (uptr)&ENTRYOFFSET(_cp));\
- ptr _pp = (ptr)((uptr)_cp - _co);\
- if (FWDMARKER(_pp) == forward_marker)\
- _pp = FWDADDRESS(_pp);\
- else\
- (void) copy(_pp, _si, &_pp ACTUAL_CTGS);\
- *_pcp = (ptr)((uptr)_pp + _co);\
- }\
-} while (0)
-
-/* use relocate_dirty for oldspace fields that might hold pointers to younger objects */
-#define relocate_dirty(PPP, YOUNGEST) do {\
- seginfo *_si; ptr *_ppp = PPP, _pp = *_ppp; IGEN _pg;\
- if (!IMMEDIATE(_pp) && (_si = MaybeSegInfo(ptr_get_segment(_pp))) != NULL) {\
- if (!(_si->space & space_old)) {\
- _pg = _si->generation;\
- } else if (FWDMARKER(_pp) == forward_marker && TYPEBITS(_pp) != type_flonum) {\
- *_ppp = FWDADDRESS(_pp);\
- _pg = compute_target_generation(_si->generation ACTUAL_CTGS);\
- } else {\
- _pg = copy(_pp, _si, _ppp ACTUAL_CTGS);\
- }\
- if (_pg < YOUNGEST) YOUNGEST = _pg;\
- }\
-} while (0)
-
-/* use relocate_pure for newspace fields that can't point to younger objects */
-#define relocate_pure_help(PPP, PP) do {\
- ptr *__ppp = PPP, __pp = PP; seginfo *__si;\
- if (!IMMEDIATE(__pp) && (__si = MaybeSegInfo(ptr_get_segment(__pp))) != NULL && (__si->space & space_old)) {\
- if (FWDMARKER(__pp) == forward_marker && TYPEBITS(__pp) != type_flonum) {\
- *__ppp = FWDADDRESS(__pp);\
- } else {\
- (void) copy(__pp, __si, __ppp ACTUAL_CTGS);\
- }\
- }\
-} while (0)
-
-#define relocate_pure(PPP) do {\
- ptr *_ppp = PPP; relocate_pure_help(_ppp, *_ppp);\
-} while (0)
-
-/* use relocate_impure for newspace fields that can point to younger objects */
-#ifdef NO_DIRTY_NEWSPACE_POINTERS
-#define relocate_impure_help(PPP, PP, FROM_G) do {(void)FROM_G; relocate_pure_help(PPP, PP);} while (0)
-#define relocate_impure(PPP, FROM_G) do {(void)FROM_G; relocate_pure(PPP);} while (0)
-#else /* !NO_DIRTY_NEWSPACE_POINTERS */
-/* the initialization of __to_g to 0 below shouldn't be necessary, but gcc 7.5.0 complains without it */
-#define relocate_impure_help(PPP, PP, FROM_G) do {\
- ptr *__ppp = PPP, __pp = PP; IGEN __from_g = FROM_G;\
- seginfo *__si; IGEN __to_g = 0;\
- if (!IMMEDIATE(__pp) && (__si = MaybeSegInfo(ptr_get_segment(__pp))) != NULL && (__si->space & space_old)) {\
- if (FWDMARKER(__pp) == forward_marker && TYPEBITS(__pp) != type_flonum ?\
- (*__ppp = FWDADDRESS(__pp), (__from_g > 1 && (__to_g = compute_target_generation(__si->generation ACTUAL_CTGS)) < __from_g)) :\
- ((__to_g = copy(__pp, __si, __ppp ACTUAL_CTGS)) < __from_g)) {\
- record_new_dirty_card(__ppp, __to_g);\
- }\
- }\
-} while (0)
-
-#define relocate_impure(PPP, FROM_G) do {\
- ptr *_ppp = PPP; relocate_impure_help(_ppp, *_ppp, FROM_G);\
-} while (0)
-#endif /* !NO_DIRTY_NEWSPACE_POINTERS */
-
-#ifndef NO_DIRTY_NEWSPACE_POINTERS
-typedef struct _dirtycardinfo {
- uptr card;
- IGEN youngest;
- struct _dirtycardinfo *next;
-} dirtycardinfo;
-
-static dirtycardinfo *new_dirty_cards;
-
-static void record_new_dirty_card(ptr *ppp, IGEN to_g) {
- uptr card = (uptr)ppp >> card_offset_bits;
-
- dirtycardinfo *ndc = new_dirty_cards;
- if (ndc != NULL && ndc->card == card) {
- if (to_g < ndc->youngest) ndc->youngest = to_g;
- } else {
- dirtycardinfo *next = ndc;
- find_room(space_new, 0, typemod, ptr_align(sizeof(dirtycardinfo)), ndc);
- ndc->card = card;
- ndc->youngest = to_g;
- ndc->next = next;
- new_dirty_cards = ndc;
- }
-}
-#endif
-
-/* rkd 2015/06/05: tried to use sse instructions. abandoned the code
- because the collector ran slower */
-#define copy_ptrs(ty, p1, p2, n) {\
- ptr *Q1, *Q2, *Q1END;\
- Q1 = (ptr *)UNTYPE((p1),ty);\
- Q2 = (ptr *)UNTYPE((p2),ty);\
- Q1END = (ptr *)((uptr)Q1 + n);\
- while (Q1 != Q1END) *Q1++ = *Q2++;}
-
-#ifdef NO_LOCKED_OLDSPACE_OBJECTS
-#define locked(p) 0
-#else /* !NO_LOCKED_OLDSPACE_OBJECTS */
-/* MAXPTR is used to pad the sorted_locked_object vector. The pad value must be greater than any heap address */
-#define MAXPTR ((ptr)-1)
-
-static ptr append_bang(ptr ls1, ptr ls2) { /* assumes ls2 pairs are older than ls1 pairs, or that we don't care */
- if (ls2 == Snil) {
- return ls1;
- } else if (ls1 == Snil) {
- return ls2;
- } else {
- ptr this = ls1, next;
- while ((next = Scdr(this)) != Snil) this = next;
- INITCDR(this) = ls2;
- return ls1;
- }
-}
-
-static uptr count_unique(ptr ls) { /* assumes ls is sorted and nonempty */
- uptr i = 1; ptr x = Scar(ls), y;
- while ((ls = Scdr(ls)) != Snil) {
- if ((y = Scar(ls)) != x) {
- i += 1;
- x = y;
- }
- }
- return i;
-}
-
-#define CARLT(x, y) (Scar(x) < Scar(y))
-mkmergesort(dosort, domerge, ptr, Snil, CARLT, INITCDR)
-
-uptr list_length(ptr ls) {
- uptr i = 0;
- while (ls != Snil) { ls = Scdr(ls); i += 1; }
- return i;
-}
-
-static IBOOL search_locked(ptr p) {
- uptr k; ptr v, *vp, x;
- v = sorted_locked_objects;
- k = Svector_length(v);
- vp = &INITVECTIT(v, 0);
- for (;;) {
- k >>= 1;
- if ((x = vp[k]) == p) return 1;
- if (k == 0) return 0;
- if (x < p) vp += k + 1;
- }
-}
-
-#define locked(p) (sorted_locked_objects != FIX(0) && search_locked(p))
-#endif /* !NO_LOCKED_OLDSPACE_OBJECTS */
-
-FORCEINLINE void check_trigger_ephemerons(seginfo *si) {
- /* Registering ephemerons to recheck at the granularity of a segment
- means that the worst-case complexity of GC is quadratic in the
- number of objects that fit into a segment (but that only happens
- if the objects are ephemeron keys that are reachable just through
- a chain via the value field of the same ephemerons). */
- if (si->trigger_ephemerons) {
- add_trigger_ephemerons_to_repending(si->trigger_ephemerons);
- si->trigger_ephemerons = NULL;
- }
-}
-
-static IGEN copy(ptr pp, seginfo *si, ptr *ppp FORMAL_CTGS) {
- ptr p, tf; ITYPE t;
- IGEN newg = compute_target_generation(si->generation ACTUAL_CTGS);
-
-#ifndef NO_LOCKED_OLDSPACE_OBJECTS
- if (locked(pp)) { *ppp = pp; return newg; }
-#endif /* !NO_LOCKED_OLDSPACE_OBJECTS */
-
- change = 1;
-
- check_trigger_ephemerons(si);
-
- if ((t = TYPEBITS(pp)) == type_typed_object) {
- tf = TYPEFIELD(pp);
- if (TYPEP(tf, mask_record, type_record)) {
- ptr rtd; iptr n; ISPC s;
-
- /* relocate to make sure we aren't using an oldspace descriptor
- that has been overwritten by a forwarding marker, but don't loop
- on tag-reflexive base descriptor */
- if ((rtd = tf) != pp) relocate_pure(&rtd);
-
- n = size_record_inst(UNFIX(RECORDDESCSIZE(rtd)));
-
-#ifdef ENABLE_OBJECT_COUNTS
- { ptr counts; IGEN g;
- counts = RECORDDESCCOUNTS(rtd);
- if (counts == Sfalse) {
- IGEN grtd = rtd == pp ? newg : GENERATION(rtd);
- S_G.countof[grtd][countof_rtd_counts] += 1;
- /* allocate counts struct in same generation as rtd. initialize timestamp & counts */
- find_room(space_data, grtd, type_typed_object, size_rtd_counts, counts);
- RTDCOUNTSTYPE(counts) = type_rtd_counts;
- RTDCOUNTSTIMESTAMP(counts) = S_G.gctimestamp[0];
- for (g = 0; g <= static_generation; g += 1) RTDCOUNTSIT(counts, g) = 0;
- RECORDDESCCOUNTS(rtd) = counts;
- S_G.rtds_with_counts[grtd] = S_cons_in((grtd == 0 ? space_new : space_impure), grtd, rtd, S_G.rtds_with_counts[grtd]);
- S_G.countof[grtd][countof_pair] += 1;
- } else {
- relocate_pure(&counts);
- RECORDDESCCOUNTS(rtd) = counts;
- if (RTDCOUNTSTIMESTAMP(counts) != S_G.gctimestamp[0]) S_fixup_counts(counts);
- }
- RTDCOUNTSIT(counts, newg) += 1;
- }
-#endif /* ENABLE_OBJECT_COUNTS */
-
- /* if the rtd is the only pointer and is immutable, put the record
- into space data. if the record contains only pointers, put it
- into space_pure or space_impure. otherwise put it into
- space_pure_typed_object or space_impure_record. we could put all
- records into space_{pure,impure}_record or even into
- space_impure_record, but by picking the target space more
- carefully we may reduce fragmentation and sweeping cost */
- s = RECORDDESCPM(rtd) == FIX(1) && RECORDDESCMPM(rtd) == FIX(0) ?
- space_data :
- RECORDDESCPM(rtd) == FIX(-1) ?
- RECORDDESCMPM(rtd) == FIX(0) ?
- space_pure :
- space_impure :
- RECORDDESCMPM(rtd) == FIX(0) ?
- space_pure_typed_object :
- space_impure_record;
-
- find_room(s, newg, type_typed_object, n, p);
- copy_ptrs(type_typed_object, p, pp, n);
-
- /* overwrite type field with forwarded descriptor */
- RECORDINSTTYPE(p) = rtd == pp ? p : rtd;
-
- /* pad if necessary */
- if (s == space_pure || s == space_impure) {
- iptr m = unaligned_size_record_inst(UNFIX(RECORDDESCSIZE(rtd)));
- if (m != n)
- *((ptr *)((uptr)UNTYPE(p,type_typed_object) + m)) = FIX(0);
- }
- } else if (TYPEP(tf, mask_vector, type_vector)) {
- iptr len, n;
- len = Svector_length(pp);
- n = size_vector(len);
-#ifdef ENABLE_OBJECT_COUNTS
- S_G.countof[newg][countof_vector] += 1;
- S_G.bytesof[newg][countof_vector] += n;
-#endif /* ENABLE_OBJECT_COUNTS */
- /* assumes vector lengths look like fixnums; if not, vectors will need their own space */
- if ((uptr)tf & vector_immutable_flag) {
- find_room(space_pure, newg, type_typed_object, n, p);
- } else {
- find_room(space_impure, newg, type_typed_object, n, p);
- }
- copy_ptrs(type_typed_object, p, pp, n);
- /* pad if necessary */
- if ((len & 1) == 0) INITVECTIT(p, len) = FIX(0);
- } else if (TYPEP(tf, mask_string, type_string)) {
- iptr n;
- n = size_string(Sstring_length(pp));
-#ifdef ENABLE_OBJECT_COUNTS
- S_G.countof[newg][countof_string] += 1;
- S_G.bytesof[newg][countof_string] += n;
-#endif /* ENABLE_OBJECT_COUNTS */
- find_room(space_data, newg, type_typed_object, n, p);
- copy_ptrs(type_typed_object, p, pp, n);
- } else if (TYPEP(tf, mask_bytevector, type_bytevector)) {
- iptr n;
- n = size_bytevector(Sbytevector_length(pp));
-#ifdef ENABLE_OBJECT_COUNTS
- S_G.countof[newg][countof_bytevector] += 1;
- S_G.bytesof[newg][countof_bytevector] += n;
-#endif /* ENABLE_OBJECT_COUNTS */
- find_room(space_data, newg, type_typed_object, n, p);
- copy_ptrs(type_typed_object, p, pp, n);
- } else if ((iptr)tf == type_tlc) {
- ptr keyval, next;
-
-#ifdef ENABLE_OBJECT_COUNTS
- S_G.countof[newg][countof_tlc] += 1;
-#endif /* ENABLE_OBJECT_COUNTS */
- find_room(space_impure, newg, type_typed_object, size_tlc, p);
- TLCTYPE(p) = type_tlc;
- INITTLCKEYVAL(p) = keyval = TLCKEYVAL(pp);
- INITTLCHT(p) = TLCHT(pp);
- INITTLCNEXT(p) = next = TLCNEXT(pp);
-
- /* if next isn't false and keyval is old, add tlc to a list of tlcs
- * to process later. determining if keyval is old is a (conservative)
- * approximation to determining if key is old. we can't easily
- * determine if key is old, since keyval might or might not have been
- * swept already. NB: assuming keyvals are always pairs. */
- if (next != Sfalse && SPACE(keyval) & space_old)
- tlcs_to_rehash = S_cons_in(space_new, 0, p, tlcs_to_rehash);
- } else if (TYPEP(tf, mask_box, type_box)) {
-#ifdef ENABLE_OBJECT_COUNTS
- S_G.countof[newg][countof_box] += 1;
-#endif /* ENABLE_OBJECT_COUNTS */
- if ((uptr)tf == type_immutable_box) {
- find_room(space_pure, newg, type_typed_object, size_box, p);
- } else {
- find_room(space_impure, newg, type_typed_object, size_box, p);
- }
- BOXTYPE(p) = (iptr)tf;
- INITBOXREF(p) = Sunbox(pp);
- } else if (TYPEP(tf, mask_fxvector, type_fxvector)) {
- iptr n;
- n = size_fxvector(Sfxvector_length(pp));
-#ifdef ENABLE_OBJECT_COUNTS
- S_G.countof[newg][countof_fxvector] += 1;
- S_G.bytesof[newg][countof_fxvector] += n;
-#endif /* ENABLE_OBJECT_COUNTS */
- find_room(space_data, newg, type_typed_object, n, p);
- copy_ptrs(type_typed_object, p, pp, n);
- } else if ((iptr)tf == type_ratnum) {
- /* not recursive: place in space_data and relocate fields immediately */
-#ifdef ENABLE_OBJECT_COUNTS
- S_G.countof[newg][countof_ratnum] += 1;
-#endif /* ENABLE_OBJECT_COUNTS */
- find_room(space_data, newg,
- type_typed_object, size_ratnum, p);
- RATTYPE(p) = type_ratnum;
- RATNUM(p) = RATNUM(pp);
- RATDEN(p) = RATDEN(pp);
- relocate_pure(&RATNUM(p));
- relocate_pure(&RATDEN(p));
- } else if ((iptr)tf == type_exactnum) {
- /* not recursive: place in space_data and relocate fields immediately */
-#ifdef ENABLE_OBJECT_COUNTS
- S_G.countof[newg][countof_exactnum] += 1;
-#endif /* ENABLE_OBJECT_COUNTS */
- find_room(space_data, newg,
- type_typed_object, size_exactnum, p);
- EXACTNUM_TYPE(p) = type_exactnum;
- EXACTNUM_REAL_PART(p) = EXACTNUM_REAL_PART(pp);
- EXACTNUM_IMAG_PART(p) = EXACTNUM_IMAG_PART(pp);
- relocate_pure(&EXACTNUM_REAL_PART(p));
- relocate_pure(&EXACTNUM_IMAG_PART(p));
- } else if ((iptr)tf == type_inexactnum) {
-#ifdef ENABLE_OBJECT_COUNTS
- S_G.countof[newg][countof_inexactnum] += 1;
-#endif /* ENABLE_OBJECT_COUNTS */
- find_room(space_data, newg,
- type_typed_object, size_inexactnum, p);
- INEXACTNUM_TYPE(p) = type_inexactnum;
- INEXACTNUM_REAL_PART(p) = INEXACTNUM_REAL_PART(pp);
- INEXACTNUM_IMAG_PART(p) = INEXACTNUM_IMAG_PART(pp);
- } else if (TYPEP(tf, mask_bignum, type_bignum)) {
- iptr n;
- n = size_bignum(BIGLEN(pp));
-#ifdef ENABLE_OBJECT_COUNTS
- S_G.countof[newg][countof_bignum] += 1;
- S_G.bytesof[newg][countof_bignum] += n;
-#endif /* ENABLE_OBJECT_COUNTS */
- find_room(space_data, newg, type_typed_object, n, p);
- copy_ptrs(type_typed_object, p, pp, n);
- } else if (TYPEP(tf, mask_port, type_port)) {
-#ifdef ENABLE_OBJECT_COUNTS
- S_G.countof[newg][countof_port] += 1;
-#endif /* ENABLE_OBJECT_COUNTS */
- find_room(space_port, newg, type_typed_object, size_port, p);
- PORTTYPE(p) = PORTTYPE(pp);
- PORTHANDLER(p) = PORTHANDLER(pp);
- PORTNAME(p) = PORTNAME(pp);
- PORTINFO(p) = PORTINFO(pp);
- PORTOCNT(p) = PORTOCNT(pp);
- PORTICNT(p) = PORTICNT(pp);
- PORTOBUF(p) = PORTOBUF(pp);
- PORTOLAST(p) = PORTOLAST(pp);
- PORTIBUF(p) = PORTIBUF(pp);
- PORTILAST(p) = PORTILAST(pp);
- } else if (TYPEP(tf, mask_code, type_code)) {
- iptr n;
- n = size_code(CODELEN(pp));
-#ifdef ENABLE_OBJECT_COUNTS
- S_G.countof[newg][countof_code] += 1;
- S_G.bytesof[newg][countof_code] += n;
-#endif /* ENABLE_OBJECT_COUNTS */
- find_room(space_code, newg, type_typed_object, n, p);
- copy_ptrs(type_typed_object, p, pp, n);
- } else if ((iptr)tf == type_thread) {
-#ifdef ENABLE_OBJECT_COUNTS
- S_G.countof[newg][countof_thread] += 1;
-#endif /* ENABLE_OBJECT_COUNTS */
- find_room(space_pure_typed_object, newg,
- type_typed_object, size_thread, p);
- TYPEFIELD(p) = (ptr)type_thread;
- THREADTC(p) = THREADTC(pp); /* static */
- } else if ((iptr)tf == type_rtd_counts) {
-#ifdef ENABLE_OBJECT_COUNTS
- S_G.countof[newg][countof_rtd_counts] += 1;
-#endif /* ENABLE_OBJECT_COUNTS */
- find_room(space_data, newg, type_typed_object, size_rtd_counts, p);
- copy_ptrs(type_typed_object, p, pp, size_rtd_counts);
- } else {
- S_error_abort("copy(gc): illegal type");
- return newg /* not reached */;
- }
- } else if (t == type_pair) {
- if (si->space == (space_ephemeron | space_old)) {
-#ifdef ENABLE_OBJECT_COUNTS
- S_G.countof[newg][countof_ephemeron] += 1;
-#endif /* ENABLE_OBJECT_COUNTS */
- find_room(space_ephemeron, newg, type_pair, size_ephemeron, p);
- INITCAR(p) = Scar(pp);
- INITCDR(p) = Scdr(pp);
- } else {
- ptr qq = Scdr(pp); ptr q;
- if (qq != pp && TYPEBITS(qq) == type_pair && ptr_get_segment(qq) == ptr_get_segment(pp) && FWDMARKER(qq) != forward_marker && !locked(qq)) {
- if (si->space == (space_weakpair | space_old)) {
-#ifdef ENABLE_OBJECT_COUNTS
- S_G.countof[newg][countof_weakpair] += 2;
-#endif /* ENABLE_OBJECT_COUNTS */
- find_room(space_weakpair, newg, type_pair, 2 * size_pair, p);
- } else {
-#ifdef ENABLE_OBJECT_COUNTS
- S_G.countof[newg][countof_pair] += 2;
-#endif /* ENABLE_OBJECT_COUNTS */
- find_room(space_impure, newg, type_pair, 2 * size_pair, p);
- }
- q = (ptr)((uptr)p + size_pair);
- INITCAR(p) = Scar(pp);
- INITCDR(p) = q;
- INITCAR(q) = Scar(qq);
- INITCDR(q) = Scdr(qq);
- FWDMARKER(qq) = forward_marker;
- FWDADDRESS(qq) = q;
- } else {
- if (si->space == (space_weakpair | space_old)) {
-#ifdef ENABLE_OBJECT_COUNTS
- S_G.countof[newg][countof_weakpair] += 1;
-#endif /* ENABLE_OBJECT_COUNTS */
- find_room(space_weakpair, newg, type_pair, size_pair, p);
- } else {
-#ifdef ENABLE_OBJECT_COUNTS
- S_G.countof[newg][countof_pair] += 1;
-#endif /* ENABLE_OBJECT_COUNTS */
- find_room(space_impure, newg, type_pair, size_pair, p);
- }
- INITCAR(p) = Scar(pp);
- INITCDR(p) = qq;
- }
- }
- } else if (t == type_closure) {
- ptr code;
-
- /* relocate before accessing code type field, which otherwise might
- be a forwarding marker */
- code = CLOSCODE(pp);
- relocate_pure(&code);
- if (CODETYPE(code) & (code_flag_continuation << code_flags_offset)) {
-#ifdef ENABLE_OBJECT_COUNTS
- S_G.countof[newg][countof_continuation] += 1;
-#endif /* ENABLE_OBJECT_COUNTS */
- find_room(space_continuation, newg,
- type_closure, size_continuation, p);
- SETCLOSCODE(p,code);
- /* don't promote one-shots */
- CONTLENGTH(p) = CONTLENGTH(pp);
- CONTCLENGTH(p) = CONTCLENGTH(pp);
- CONTWINDERS(p) = CONTWINDERS(pp);
- if (CONTLENGTH(p) != scaled_shot_1_shot_flag) {
- CONTLINK(p) = CONTLINK(pp);
- CONTRET(p) = CONTRET(pp);
- CONTSTACK(p) = CONTSTACK(pp);
- }
- } else {
- iptr len, n;
- len = CLOSLEN(pp);
- n = size_closure(len);
-#ifdef ENABLE_OBJECT_COUNTS
- S_G.countof[newg][countof_closure] += 1;
- S_G.bytesof[newg][countof_closure] += n;
-#endif /* ENABLE_OBJECT_COUNTS */
- find_room(space_pure, newg, type_closure, n, p);
- copy_ptrs(type_closure, p, pp, n);
- SETCLOSCODE(p,code);
- /* pad if necessary */
- if ((len & 1) == 0) CLOSIT(p, len) = FIX(0);
- }
- } else if (t == type_symbol) {
-#ifdef ENABLE_OBJECT_COUNTS
- S_G.countof[newg][countof_symbol] += 1;
-#endif /* ENABLE_OBJECT_COUNTS */
- find_room(space_symbol, newg, type_symbol, size_symbol, p);
- INITSYMVAL(p) = SYMVAL(pp);
- INITSYMPVAL(p) = SYMPVAL(pp);
- INITSYMPLIST(p) = SYMPLIST(pp);
- INITSYMSPLIST(p) = SYMSPLIST(pp);
- INITSYMNAME(p) = SYMNAME(pp);
- INITSYMHASH(p) = SYMHASH(pp);
- } else if (t == type_flonum) {
-#ifdef ENABLE_OBJECT_COUNTS
- S_G.countof[newg][countof_flonum] += 1;
-#endif /* ENABLE_OBJECT_COUNTS */
- find_room(space_data, newg, type_flonum, size_flonum, p);
- FLODAT(p) = FLODAT(pp);
- /* no room for forwarding address, so let 'em be duplicated */
- *ppp = p;
- return newg;
- } else {
- S_error_abort("copy(gc): illegal type");
- return newg /* not reached */;
- }
-
- FWDMARKER(pp) = forward_marker;
- FWDADDRESS(pp) = p;
-
- *ppp = p;
- return newg;
-}
-
-static void sweep_locked_ptrs(ptr *pp, iptr n FORMAL_CTGS) {
- ptr *end = pp + n;
-
- while (pp != end) {
- relocate_pure(pp);
- pp += 1;
- }
-}
-
-static void sweep_locked(ptr tc, ptr p, IBOOL sweep_pure FORMAL_CTGS) {
- ptr tf; ITYPE t;
-
- if ((t = TYPEBITS(p)) == type_pair) {
- ISPC s = SPACE(p) & ~(space_locked | space_old);
- if (s == space_ephemeron)
- add_ephemeron_to_pending(p);
- else {
- if (s != space_weakpair) {
- relocate_pure(&INITCAR(p));
- }
- relocate_pure(&INITCDR(p));
- }
- } else if (t == type_closure) {
- if (sweep_pure) {
- ptr code;
-
- code = CLOSCODE(p);
- relocate_pure(&code);
- SETCLOSCODE(p,code);
- if (CODETYPE(code) & (code_flag_continuation << code_flags_offset))
- sweep_continuation(p ACTUAL_CTGS);
- else
- sweep_locked_ptrs(&CLOSIT(p, 0), CLOSLEN(p) ACTUAL_CTGS);
- }
- } else if (t == type_symbol) {
- sweep_symbol(p, 0 ACTUAL_CTGS);
- } else if (t == type_flonum) {
- /* nothing to sweep */;
- /* typed objects */
- } else if (tf = TYPEFIELD(p), TYPEP(tf, mask_vector, type_vector)) {
- sweep_locked_ptrs(&INITVECTIT(p, 0), Svector_length(p) ACTUAL_CTGS);
- } else if (TYPEP(tf, mask_string, type_string) || TYPEP(tf, mask_bytevector, type_bytevector) || TYPEP(tf, mask_fxvector, type_fxvector)) {
- /* nothing to sweep */;
- } else if (TYPEP(tf, mask_record, type_record)) {
- relocate_pure(&RECORDINSTTYPE(p));
- if (sweep_pure || RECORDDESCMPM(RECORDINSTTYPE(p)) != FIX(0)) {
- sweep_record(p, 0 ACTUAL_CTGS);
- }
- } else if (TYPEP(tf, mask_box, type_box)) {
- relocate_pure(&INITBOXREF(p));
- } else if ((iptr)tf == type_ratnum) {
- if (sweep_pure) {
- relocate_pure(&RATNUM(p));
- relocate_pure(&RATDEN(p));
- }
- } else if ((iptr)tf == type_exactnum) {
- if (sweep_pure) {
- relocate_pure(&EXACTNUM_REAL_PART(p));
- relocate_pure(&EXACTNUM_IMAG_PART(p));
- }
- } else if ((iptr)tf == type_inexactnum) {
- /* nothing to sweep */;
- } else if (TYPEP(tf, mask_bignum, type_bignum)) {
- /* nothing to sweep */;
- } else if (TYPEP(tf, mask_port, type_port)) {
- sweep_port(p, 0 ACTUAL_CTGS);
- } else if (TYPEP(tf, mask_code, type_code)) {
- if (sweep_pure) {
- sweep_code_object(tc, p ACTUAL_CTGS);
- }
- } else if ((iptr)tf == type_thread) {
- sweep_thread(p ACTUAL_CTGS);
- } else if ((iptr)tf == type_rtd_counts) {
- /* nothing to sweep */;
- } else {
- S_error_abort("sweep_locked(gc): illegal type");
- }
-}
-
-static ptr copy_stack(ptr old, iptr *length, iptr clength FORMAL_CTGS) {
- iptr n, m; ptr new; IGEN newg;
-
- /* Don't copy non-oldspace stacks, since we may be sweeping a locked
- continuation. Doing so would be a waste of work anyway. */
- if (!OLDSPACE(old)) return old;
-
- newg = compute_target_generation(GENERATION(old) ACTUAL_CTGS);
-
- /* reduce headroom created for excessively large frames (typically resulting from apply with long lists) */
- if ((n = *length) != clength && n > default_stack_size && n > (m = clength + one_shot_headroom)) {
- *length = n = m;
- }
-
- n = ptr_align(n);
-#ifdef ENABLE_OBJECT_COUNTS
- S_G.countof[newg][countof_stack] += 1;
- S_G.bytesof[newg][countof_stack] += n;
-#endif /* ENABLE_OBJECT_COUNTS */
- find_room(space_data, newg, typemod, n, new);
- n = ptr_align(clength);
- /* warning: stack may have been left non-double-aligned by split_and_resize */
- copy_ptrs(typemod, new, old, n);
-
- /* also returning possibly updated value in *length */
- return new;
-}
-
-#define NONSTATICINHEAP(si, x) (!IMMEDIATE(x) && (si = MaybeSegInfo(ptr_get_segment(x))) != NULL && si->generation != static_generation)
-#define ALWAYSTRUE(si, x) (si = SegInfo(ptr_get_segment(x)), 1)
-#define partition_guardians(LS, FILTER) { \
- ptr ls; seginfo *si;\
- for (ls = LS; ls != Snil; ls = next) { \
- obj = GUARDIANOBJ(ls); \
- next = GUARDIANNEXT(ls); \
- \
- if (FILTER(si, obj)) { \
- if (!(si->space & space_old) || locked(obj) || ((FWDMARKER(obj) == forward_marker && TYPEBITS(obj) != type_flonum) && (INITGUARDIANOBJ(ls) = FWDADDRESS(obj), 1))) { \
- INITGUARDIANNEXT(ls) = pend_hold_ls; \
- pend_hold_ls = ls; \
- } else { \
- tconc = GUARDIANTCONC(ls); \
- if (!OLDSPACE(tconc) || locked(tconc) || ((FWDMARKER(tconc) == forward_marker) && (INITGUARDIANTCONC(ls) = FWDADDRESS(tconc), 1))) { \
- INITGUARDIANNEXT(ls) = final_ls; \
- final_ls = ls; \
- } else { \
- INITGUARDIANNEXT(ls) = pend_final_ls; \
- pend_final_ls = ls; \
- } \
- } \
- } \
- } \
-}
-
-/* tc: thread context
- * max_cg: maximum copied generation, i.e., maximum generation subject to collection. max_cg >= 0 && max_cg <= 255.
- * min_tg: minimum target generation. max_tg == 0 ? min_tg == 0 : min_tg > 0 && min_tg <= max_tg;
- * max_tg: maximum target generation. max_tg == max_cg || max_tg == max_cg + 1.
- * Objects in generation g are collected into generation MIN(max_tg, MAX(min_tg, g+1)).
- */
-void GCENTRY GCENTRY_PROTO(ptr tc, IGEN max_cg, IGEN min_tg, IGEN max_tg) {
- IGEN g; ISPC s;
- seginfo *oldspacesegments, *si, *nextsi;
- ptr ls;
- bucket_pointer_list *buckets_to_rebuild;
-#ifndef NO_LOCKED_OLDSPACE_OBJECTS
- ptr locked_oldspace_objects;
-#endif /* !NO_LOCKED_OLDSPACE_OBJECTS */
- DECLARE_CTGS(max_cg, min_tg, max_tg);
-
- /* flush instruction cache: effectively clear_code_mod but safer */
- for (ls = S_threads; ls != Snil; ls = Scdr(ls)) {
- ptr tc = (ptr)THREADTC(Scar(ls));
- S_flush_instruction_cache(tc);
- }
-
- tlcs_to_rehash = Snil;
-#ifndef NO_DIRTY_NEWSPACE_POINTERS
- new_dirty_cards = NULL;
-#endif /* !NO_DIRTY_NEWSPACE_POINTERS */
-
- for (ls = S_threads; ls != Snil; ls = Scdr(ls)) {
- ptr tc = (ptr)THREADTC(Scar(ls));
- S_scan_dirty((ptr **)EAP(tc), (ptr **)REAL_EAP(tc));
- EAP(tc) = REAL_EAP(tc) = AP(tc) = (ptr)0;
- }
-
- /* perform after ScanDirty */
- if (S_checkheap) S_check_heap(0);
-
-#ifdef DEBUG
-(void)printf("max_cg = %x; go? ", max_cg); (void)fflush(stdout); (void)getc(stdin);
-#endif
-
- /* set up generations to be copied */
- for (g = 0; g <= max_cg; g++) {
- S_G.bytes_of_generation[g] = 0;
- for (s = 0; s <= max_real_space; s++) {
- S_G.base_loc[g][s] = FIX(0);
- S_G.first_loc[g][s] = FIX(0);
- S_G.next_loc[g][s] = FIX(0);
- S_G.bytes_left[g][s] = 0;
- S_G.bytes_of_space[g][s] = 0;
- }
- }
-
- /* set up target generation sweep_loc and orig_next_loc pointers */
- for (g = min_tg; g <= max_tg; g += 1) {
- for (s = 0; s <= max_real_space; s++) {
- /* for all but max_tg (and max_tg as well, if max_tg == max_cg), this
- will set orig_net_loc and sweep_loc to 0 */
- orig_next_loc[g][s] = sweep_loc[g][s] = S_G.next_loc[g][s];
- }
- }
-
- /* mark segments from which objects are to be copied */
- oldspacesegments = (seginfo *)NULL;
- for (g = 0; g <= max_cg; g += 1) {
- for (s = 0; s <= max_real_space; s += 1) {
- for (si = S_G.occupied_segments[g][s]; si != NULL; si = nextsi) {
- nextsi = si->next;
- si->next = oldspacesegments;
- oldspacesegments = si;
- si->space = s | space_old; /* NB: implicitly clearing space_locked */
- }
- S_G.occupied_segments[g][s] = NULL;
- }
- }
-
-#ifdef ENABLE_OBJECT_COUNTS
- /* clear object counts & bytes for copied generations; bump timestamp */
- {INT i;
- for (g = 0; g <= max_cg; g += 1) {
- for (i = 0; i < countof_types; i += 1) {
- S_G.countof[g][i] = 0;
- S_G.bytesof[g][i] = 0;
- }
- if (g == 0) {
- S_G.gctimestamp[g] += 1;
- } else {
- S_G.gctimestamp[g] = S_G.gctimestamp[0];
- }
- }
- }
-#endif /* ENABLE_OBJECT_COUNTS */
-
- /* pre-collection handling of locked objects. */
-
-#ifndef NO_LOCKED_OLDSPACE_OBJECTS
- /* create a single sorted_locked_object vector for all copied generations
- * to accelerate the search for locked objects in copy(). copy wants
- * a vector of some size n=2^k-1 so it doesn't have to check bounds */
- ls = Snil;
- /* note: append_bang and dosort reuse pairs, which can result in older
- * objects pointing to newer ones...but we don't care since they are all
- * oldspace and going away after this collection. */
- for (g = 0; g <= max_cg; g += 1) {
- ls = append_bang(S_G.locked_objects[g], ls);
- S_G.locked_objects[g] = Snil;
- S_G.unlocked_objects[g] = Snil;
- }
- if (ls == Snil) {
- sorted_locked_objects = FIX(0);
- locked_oldspace_objects = Snil;
- } else {
- ptr v, x, y; uptr i, n;
-
- /* dosort is destructive, so have to store the result back */
- locked_oldspace_objects = ls = dosort(ls, list_length(ls));
-
- /* create vector of smallest size n=2^k-1 that will fit all of
- the list's unique elements */
- i = count_unique(ls);
- for (n = 1; n < i; n = (n << 1) | 1);
- sorted_locked_objects = v = S_vector_in(space_new, 0, n);
-
- /* copy list elements in, skipping duplicates */
- INITVECTIT(v,0) = x = Scar(ls);
- i = 1;
- while ((ls = Scdr(ls)) != Snil) {
- if ((y = Scar(ls)) != x) {
- INITVECTIT(v, i) = x = y;
- i += 1;
- }
- }
-
- /* fill remaining slots with largest ptr value */
- while (i < n) { INITVECTIT(v, i) = MAXPTR; i += 1; }
- }
-#endif /* !NO_LOCKED_OLDSPACE_OBJECTS */
-
- /* sweep older locked and unlocked objects */
- for (g = max_cg + 1; g <= static_generation; INCRGEN(g)) {
- for (ls = S_G.locked_objects[g]; ls != Snil; ls = Scdr(ls))
- sweep_locked(tc, Scar(ls), 0 ACTUAL_CTGS);
- for (ls = S_G.unlocked_objects[g]; ls != Snil; ls = Scdr(ls))
- sweep_locked(tc, Scar(ls), 0 ACTUAL_CTGS);
- }
-
-#ifndef NO_LOCKED_OLDSPACE_OBJECTS
- /* sweep younger locked objects, working from sorted vector to avoid redundant sweeping of duplicates */
- if (sorted_locked_objects != FIX(0)) {
- uptr i; ptr x, v, *vp;
- v = sorted_locked_objects;
- i = Svector_length(v);
- x = *(vp = &INITVECTIT(v, 0));
- do sweep_locked(tc, x, 1 ACTUAL_CTGS); while (--i != 0 && (x = *++vp) != MAXPTR);
- }
-#endif /* !NO_LOCKED_OLDSPACE_OBJECTS */
-
- /* sweep non-oldspace threads, since any thread may have an active stack */
- for (ls = S_threads; ls != Snil; ls = Scdr(ls)) {
- ptr thread;
-
- /* someone may have their paws on the list */
- if (FWDMARKER(ls) == forward_marker) ls = FWDADDRESS(ls);
-
- thread = Scar(ls);
- if (!OLDSPACE(thread)) sweep_thread(thread ACTUAL_CTGS);
- }
- relocate_pure(&S_threads);
-
- /* relocate nonempty oldspace symbols and set up list of buckets to rebuild later */
- buckets_to_rebuild = NULL;
- for (g = 0; g <= max_cg; g += 1) {
- bucket_list *bl, *blnext; bucket *b; bucket_pointer_list *bpl; bucket **oblist_cell; ptr sym; iptr idx;
- for (bl = S_G.buckets_of_generation[g]; bl != NULL; bl = blnext) {
- blnext = bl->cdr;
- b = bl->car;
- /* mark this bucket old for the rebuilding loop */
- b->next = (bucket *)((uptr)b->next | 1);
- sym = b->sym;
- idx = UNFIX(SYMHASH(sym)) % S_G.oblist_length;
- oblist_cell = &S_G.oblist[idx];
- if (!((uptr)*oblist_cell & 1)) {
- /* mark this bucket in the set */
- *oblist_cell = (bucket *)((uptr)*oblist_cell | 1);
- /* repurpose the bucket list element for the list of buckets to rebuild later */
- /* idiot_checks verifies these have the same size */
- bpl = (bucket_pointer_list *)bl;
- bpl->car = oblist_cell;
- bpl->cdr = buckets_to_rebuild;
- buckets_to_rebuild = bpl;
- }
- if (FWDMARKER(sym) != forward_marker &&
- /* coordinate with alloc.c */
- (SYMVAL(sym) != sunbound || SYMPLIST(sym) != Snil || SYMSPLIST(sym) != Snil)) {
- ptr ignore;
- copy(sym, SegInfo(ptr_get_segment(sym)), &ignore ACTUAL_CTGS);
- }
- }
- S_G.buckets_of_generation[g] = NULL;
- }
-
- /* relocate the protected C pointers */
- {uptr i;
- for (i = 0; i < S_G.protect_next; i++)
- relocate_pure(S_G.protected[i]);
- }
-
- /* sweep areas marked dirty by assignments into older generations */
- sweep_dirty(ONLY_ACTUAL_CTGS);
-
- sweep_generation(tc ACTUAL_CTGS);
-
- /* handle guardians */
- { ptr pend_hold_ls, final_ls, pend_final_ls;
- ptr obj, rep, tconc, next;
-
- /* move each entry in guardian lists into one of:
- * pend_hold_ls if obj accessible
- * final_ls if obj not accessible and tconc accessible
- * pend_final_ls if obj not accessible and tconc not accessible */
- pend_hold_ls = final_ls = pend_final_ls = Snil;
-
- for (ls = S_threads; ls != Snil; ls = Scdr(ls)) {
- ptr tc = (ptr)THREADTC(Scar(ls));
- partition_guardians(GUARDIANENTRIES(tc), NONSTATICINHEAP);
- GUARDIANENTRIES(tc) = Snil;
- }
-
- for (g = 0; g <= max_cg; g += 1) {
- partition_guardians(S_G.guardians[g], ALWAYSTRUE);
- S_G.guardians[g] = Snil;
- }
-
- /* invariants after partition_guardians:
- * for entry in pend_hold_ls, obj is !OLDSPACE or locked
- * for entry in final_ls, obj is OLDSPACE and !locked
- * for entry in final_ls, tconc is !OLDSPACE or locked
- * for entry in pend_final_ls, obj and tconc are OLDSPACE and !locked
- */
-
- while (1) {
- IBOOL relocate_rep = final_ls != Snil;
-
- /* relocate & add the final objects to their tconcs */
- for (ls = final_ls; ls != Snil; ls = GUARDIANNEXT(ls)) {
- ptr old_end, new_end;
-
- rep = GUARDIANREP(ls);
- /* ftype_guardian_rep is a marker for reference-counted ftype pointer */
- if (rep == ftype_guardian_rep) {
- INT b; uptr *addr;
- rep = GUARDIANOBJ(ls);
- if (FWDMARKER(rep) == forward_marker) rep = FWDADDRESS(rep);
- /* Caution: Building in assumption about shape of an ftype pointer */
- addr = RECORDINSTIT(rep, 0);
- LOCKED_DECR(addr, b);
- if (!b) continue;
- }
-
- relocate_pure(&rep);
-
- /* if tconc was old it's been forwarded */
- tconc = GUARDIANTCONC(ls);
-
- old_end = Scdr(tconc);
- new_end = S_cons_in(space_impure, 0, FIX(0), FIX(0));
-#ifdef ENABLE_OBJECT_COUNTS
- S_G.countof[0][countof_pair] += 1;
-#endif /* ENABLE_OBJECT_COUNTS */
-
- SETCAR(old_end,rep);
- SETCDR(old_end,new_end);
- SETCDR(tconc,new_end);
- }
-
- /* copy each entry in pend_hold_ls into its target generation if tconc accessible */
- ls = pend_hold_ls; pend_hold_ls = Snil;
- for ( ; ls != Snil; ls = next) {
- ptr p;
-
- next = GUARDIANNEXT(ls);
-
- /* discard static pend_hold_ls entries */
- g = compute_target_generation(GENERATION(ls) ACTUAL_CTGS);
- if (g == static_generation) continue;
-
- tconc = GUARDIANTCONC(ls);
-
- if (OLDSPACE(tconc) && !locked(tconc)) {
- if (FWDMARKER(tconc) == forward_marker)
- tconc = FWDADDRESS(tconc);
- else {
- INITGUARDIANNEXT(ls) = pend_hold_ls;
- pend_hold_ls = ls;
- continue;
- }
- }
-
- rep = GUARDIANREP(ls);
- relocate_pure(&rep);
- relocate_rep = 1;
-
-#ifdef ENABLE_OBJECT_COUNTS
- S_G.countof[g][countof_guardian] += 1;
-#endif /* ENABLE_OBJECT_COUNTS */
- find_room(space_pure, g, typemod, size_guardian_entry, p);
- INITGUARDIANOBJ(p) = GUARDIANOBJ(ls);
- INITGUARDIANREP(p) = rep;
- INITGUARDIANTCONC(p) = tconc;
- INITGUARDIANNEXT(p) = S_G.guardians[g];
- S_G.guardians[g] = p;
- }
-
- if (!relocate_rep) break;
-
- sweep_generation(tc ACTUAL_CTGS);
-
- /* move each entry in pend_final_ls into one of:
- * final_ls if tconc forwarded
- * pend_final_ls if tconc not forwarded */
- ls = pend_final_ls; final_ls = pend_final_ls = Snil;
- for ( ; ls != Snil; ls = next) {
- tconc = GUARDIANTCONC(ls); next = GUARDIANNEXT(ls);
-
- if (FWDMARKER(tconc) == forward_marker) {
- INITGUARDIANTCONC(ls) = FWDADDRESS(tconc);
- INITGUARDIANNEXT(ls) = final_ls;
- final_ls = ls;
- } else {
- INITGUARDIANNEXT(ls) = pend_final_ls;
- pend_final_ls = ls;
- }
- }
- }
- }
-
- /* handle weak pairs */
- resweep_dirty_weak_pairs(ONLY_ACTUAL_CTGS);
- resweep_weak_pairs(ONLY_ACTUAL_CTGS);
-
- /* still-pending ephemerons all go to bwp */
- clear_trigger_ephemerons();
-
- /* forward car fields of locked and unlocked older weak pairs */
- for (g = max_cg + 1; g <= static_generation; INCRGEN(g)) {
- for (ls = S_G.locked_objects[g]; ls != Snil; ls = Scdr(ls)) {
- ptr x = Scar(ls);
- if (Spairp(x) && (SPACE(x) & ~(space_old|space_locked)) == space_weakpair)
- forward_or_bwp(&INITCAR(x), Scar(x));
- }
- for (ls = S_G.unlocked_objects[g]; ls != Snil; ls = Scdr(ls)) {
- ptr x = Scar(ls);
- if (Spairp(x) && (SPACE(x) & ~(space_old|space_locked)) == space_weakpair)
- forward_or_bwp(&INITCAR(x), Scar(x));
- }
- }
-
-#ifndef NO_LOCKED_OLDSPACE_OBJECTS
- /* forward car fields of locked oldspace weak pairs */
- if (sorted_locked_objects != FIX(0)) {
- uptr i; ptr x, v, *vp;
- v = sorted_locked_objects;
- i = Svector_length(v);
- x = *(vp = &INITVECTIT(v, 0));
- do {
- if (Spairp(x) && (SPACE(x) & ~(space_old|space_locked)) == space_weakpair) {
- forward_or_bwp(&INITCAR(x), Scar(x));
- }
- } while (--i != 0 && (x = *++vp) != MAXPTR);
- }
-#endif /* !NO_LOCKED_OLDSPACE_OBJECTS */
-
- /* post-gc oblist handling. rebuild old buckets in the target generation, pruning unforwarded symbols */
- { bucket_list *bl; bucket *b, *bnext; bucket_pointer_list *bpl; bucket **pb; ptr sym;
- for (bpl = buckets_to_rebuild; bpl != NULL; bpl = bpl->cdr) {
- pb = bpl->car;
- for (b = (bucket *)((uptr)*pb - 1); b != NULL && ((uptr)(b->next) & 1); b = bnext) {
- bnext = (bucket *)((uptr)(b->next) - 1);
- sym = b->sym;
- if (locked(sym) || (FWDMARKER(sym) == forward_marker && ((sym = FWDADDRESS(sym)) || 1))) {
- IGEN g = GENERATION(sym);
- find_room(space_data, g, typemod, sizeof(bucket), b);
-#ifdef ENABLE_OBJECT_COUNTS
- S_G.countof[g][countof_oblist] += 1;
- S_G.bytesof[g][countof_oblist] += sizeof(bucket);
-#endif /* ENABLE_OBJECT_COUNTS */
- b->sym = sym;
- *pb = b;
- pb = &b->next;
- if (g != static_generation) {
- find_room(space_data, g, typemod, sizeof(bucket_list), bl);
-#ifdef ENABLE_OBJECT_COUNTS
- S_G.countof[g][countof_oblist] += 1;
- S_G.bytesof[g][countof_oblist] += sizeof(bucket_list);
-#endif /* ENABLE_OBJECT_COUNTS */
- bl->car = b;
- bl->cdr = S_G.buckets_of_generation[g];
- S_G.buckets_of_generation[g] = bl;
- }
- } else {
- S_G.oblist_count -= 1;
- }
- }
- *pb = b;
- }
- }
-
- /* rebuild rtds_with_counts lists, dropping otherwise inaccessible rtds */
- { IGEN g, newg; ptr ls, lsls, p;
- for (g = 0, lsls = Snil; g <= max_cg; g += 1) {
- lsls = S_cons_in(space_new, 0, S_G.rtds_with_counts[g], lsls);
- S_G.rtds_with_counts[g] = Snil;
- }
- for (; lsls != Snil; lsls = Scdr(lsls)) {
- for (ls = Scar(lsls); ls != Snil; ls = Scdr(ls)) {
- p = Scar(ls);
- if (!OLDSPACE(p) || locked(p) || (FWDMARKER(p) == forward_marker && (p = FWDADDRESS(p), 1))) {
- newg = GENERATION(p);
-#ifdef ENABLE_OBJECT_COUNTS
- S_G.countof[newg][countof_pair] += 1;
-#endif /* ENABLE_OBJECT_COUNTS */
- S_G.rtds_with_counts[newg] = S_cons_in(space_impure, newg, p, S_G.rtds_with_counts[newg]);
- }
- }
- }
- }
-
-#ifndef WIN32
- /* rebuild child_process list, reaping any that have died and refusing
- to promote into the static generation. */
- { IGEN g, newg; ptr ls, newls;
- for (g = max_cg; g >= 0; g -= 1) {
- newg = compute_target_generation(g ACTUAL_CTGS);
- if (newg == static_generation) newg = S_G.max_nonstatic_generation;
- newls = newg == g ? Snil : S_child_processes[newg];
- for (ls = S_child_processes[g], S_child_processes[g] = Snil; ls != Snil; ls = Scdr(ls)) {
- INT pid = UNFIX(Scar(ls)), status, retpid;
- retpid = waitpid(pid, &status, WNOHANG);
- if (retpid == 0 || (retpid == pid && !(WIFEXITED(status) || WIFSIGNALED(status)))) {
- newls = S_cons_in(space_impure, newg, FIX(pid), newls);
-#ifdef ENABLE_OBJECT_COUNTS
- S_G.countof[newg][countof_pair] += 1;
-#endif /* ENABLE_OBJECT_COUNTS */
- }
- }
- S_child_processes[newg] = newls;
- }
- }
-#endif /* WIN32 */
-
-#ifndef NO_LOCKED_OLDSPACE_OBJECTS
- /* post-collection handling of locked objects. This must come after
- any use of relocate or any other use of sorted_locked_objects */
- if (sorted_locked_objects != FIX(0)) {
- ptr ls, x, v, *vp; iptr i; uptr last_seg = 0, addr, seg, n; IGEN newg = 0;
-
- v = sorted_locked_objects;
-
- /* work from sorted vector to avoid redundant processing of duplicates */
- i = Svector_length(v);
- x = *(vp = &INITVECTIT(v, 0));
- do {
- /* promote the segment(s) containing x to the target generation.
- reset the space_old bit to prevent the segments from being
- reclaimed; set the locked bit to prevent sweeping by
- sweep_dirty (since the segments may contain a mix of objects,
- many of which have been discarded). */
- addr = (uptr)UNTYPE_ANY(x);
- if ((seg = addr_get_segment(addr)) == last_seg) {
- /* the generation has already been updated on this segment, and newg is still valid.
- this isn't just an optimization. if we recompute newg based on the already updated
- generation, we could get the wrong result. good thing the vector is sorted. */
- seg += 1;
- } else {
- newg = compute_target_generation(GENERATION(x) ACTUAL_CTGS);
- }
-
- n = size_object(x);
-
-#ifdef ENABLE_OBJECT_COUNTS
- S_G.countof[newg][countof_locked] += 1;
- S_G.bytesof[newg][countof_locked] += n;
-#endif /* ENABLE_OBJECT_COUNTS */
-
- addr += n - 1;
- last_seg = addr_get_segment(addr);
- while (seg <= last_seg) {
- seginfo *si = SegInfo(seg);
- si->generation = newg;
- si->space = (si->space & ~space_old) | space_locked;
- seg += 1;
- }
- } while (--i != 0 && (x = *++vp) != MAXPTR);
-
- /* add every object, including duplicates, to target-generation list(s). we do so
- even when newg == static_generation so we can keep track of static objects that need to
- be swept at the start of collection. (we could weed out pure static objects.) */
- for (newg = min_tg; newg < max_tg; newg += 1) S_G.locked_objects[newg] = Snil;
- if (max_tg == max_cg) S_G.locked_objects[max_cg] = Snil;
- for (ls = locked_oldspace_objects; ls != Snil; ls = Scdr(ls)) {
- x = Scar(ls);
- newg = GENERATION(x);
- S_G.locked_objects[newg] = S_cons_in(space_impure, newg, x, S_G.locked_objects[newg]);
-#ifdef ENABLE_OBJECT_COUNTS
- S_G.countof[newg][countof_pair] += 1;
-#endif /* ENABLE_OBJECT_COUNTS */
- }
- }
-#endif /* !NO_LOCKED_OLDSPACE_OBJECTS */
-
- /* move old space segments to empty space */
- for (si = oldspacesegments; si != NULL; si = nextsi) {
- nextsi = si->next;
- s = si->space;
- if (s & space_locked) {
- /* note: the oldspace bit is cleared above for locked objects */
- s &= ~space_locked;
- g = si->generation;
- if (g == static_generation) S_G.number_of_nonstatic_segments -= 1;
- si->next = S_G.occupied_segments[g][s];
- S_G.occupied_segments[g][s] = si;
- } else {
- chunkinfo *chunk = si->chunk;
- if (si->generation != static_generation) S_G.number_of_nonstatic_segments -= 1;
- S_G.number_of_empty_segments += 1;
- si->space = space_empty;
- si->next = chunk->unused_segs;
- chunk->unused_segs = si;
-#ifdef WIPECLEAN
- memset((void *)build_ptr(si->number,0), 0xc7, bytes_per_segment);
-#endif
- if ((chunk->nused_segs -= 1) == 0) {
- if (chunk->bytes != (minimum_segment_request + 1) * bytes_per_segment) {
- /* release oversize chunks back to the O/S immediately to avoid allocating
- * small stuff into them and thereby invite fragmentation */
- S_free_chunk(chunk);
- } else {
- S_move_to_chunk_list(chunk, &S_chunks[PARTIAL_CHUNK_POOLS]);
- }
- } else {
- S_move_to_chunk_list(chunk, &S_chunks[PARTIAL_CHUNK_POOLS-1]);
- }
- }
- }
-
- S_G.g0_bytes_after_last_gc = S_G.bytes_of_generation[0];
-
- if (max_cg >= S_G.min_free_gen) S_free_chunks();
-
- S_flush_instruction_cache(tc);
-
-#ifndef NO_DIRTY_NEWSPACE_POINTERS
- /* mark dirty those newspace cards to which we've added wrong-way pointers */
- { dirtycardinfo *ndc;
- for (ndc = new_dirty_cards; ndc != NULL; ndc = ndc->next)
- S_mark_card_dirty(ndc->card, ndc->youngest);
- }
-#endif /* !NO_DIRTY_NEWSPACE_POINTERS */
-
- if (S_checkheap) S_check_heap(1);
-
- /* post-collection rehashing of tlcs.
- must come after any use of relocate.
- logically comes after gc is entirely complete */
- while (tlcs_to_rehash != Snil) {
- ptr b, next; uptr old_idx, new_idx;
- ptr tlc = Scar(tlcs_to_rehash);
- ptr ht = TLCHT(tlc);
- ptr vec = PTRFIELD(ht,eq_hashtable_vec_disp);
- uptr veclen = Svector_length(vec);
- ptr key = Scar(TLCKEYVAL(tlc));
-
- /* scan to end of bucket to find the index */
- for (b = TLCNEXT(tlc); !Sfixnump(b); b = TLCNEXT(b));
- old_idx = UNFIX(b);
-
- if (key == Sbwp_object && PTRFIELD(ht,eq_hashtable_subtype_disp) != FIX(eq_hashtable_subtype_normal)) {
- /* remove tlc */
- b = Svector_ref(vec, old_idx);
- if (b == tlc) {
- SETVECTIT(vec, old_idx, TLCNEXT(b));
- } else {
- for (;;) { next = TLCNEXT(b); if (next == tlc) break; b = next; }
- SETTLCNEXT(b,TLCNEXT(next));
- }
- INITTLCNEXT(tlc) = Sfalse;
- INITPTRFIELD(ht,eq_hashtable_size_disp) = FIX(UNFIX(PTRFIELD(ht,eq_hashtable_size_disp)) - 1);
- } else if ((new_idx = ((uptr)key >> primary_type_bits) & (veclen - 1)) != old_idx) {
- /* remove tlc from old bucket */
- b = Svector_ref(vec, old_idx);
- if (b == tlc) {
- SETVECTIT(vec, old_idx, TLCNEXT(b));
- } else {
- for (;;) { next = TLCNEXT(b); if (next == tlc) break; b = next; }
- SETTLCNEXT(b,TLCNEXT(next));
- }
- /* and add to new bucket */
- SETTLCNEXT(tlc, Svector_ref(vec, new_idx));
- SETVECTIT(vec, new_idx, tlc);
- }
- tlcs_to_rehash = Scdr(tlcs_to_rehash);
- }
-
- S_resize_oblist();
-
- /* tell profile_release_counters to look for bwp'd counters at least through max_tg */
- if (S_G.prcgeneration < max_tg) S_G.prcgeneration = max_tg;
-}
-
-#define sweep_space(s, from_g, body) {\
- slp = &sweep_loc[from_g][s];\
- nlp = &S_G.next_loc[from_g][s];\
- if (*slp == 0) *slp = S_G.first_loc[from_g][s];\
- pp = (ptr *)*slp;\
- while (pp != (nl = (ptr *)*nlp))\
- do\
- if ((p = *pp) == forward_marker)\
- pp = (ptr *)*(pp + 1);\
- else\
- body\
- while (pp != nl);\
- *slp = (ptr)pp; \
-}
-
-static void resweep_weak_pairs(ONLY_FORMAL_CTGS) {
- IGEN from_g; ptr *slp, *nlp; ptr *pp, p, *nl;
-
- for (from_g = MIN_TG; from_g <= MAX_TG; from_g += 1) {
- sweep_loc[from_g][space_weakpair] = orig_next_loc[from_g][space_weakpair];
- sweep_space(space_weakpair, from_g, {
- forward_or_bwp(pp, p);
- pp += 2;
- })
- }
-}
-
-static void forward_or_bwp(ptr *pp, ptr p) {
- seginfo *si;
- /* adapted from relocate */
- if (!IMMEDIATE(p) && (si = MaybeSegInfo(ptr_get_segment(p))) != NULL && si->space & space_old && !locked(p)) {
- if (FWDMARKER(p) == forward_marker && TYPEBITS(p) != type_flonum) {
- *pp = FWDADDRESS(p);
- } else {
- *pp = Sbwp_object;
- }
- }
-}
-
-static void sweep_generation(ptr tc FORMAL_CTGS) {
- IGEN from_g; ptr *slp, *nlp; ptr *pp, p, *nl;
-
- do {
- change = 0;
- for (from_g = MIN_TG; from_g <= MAX_TG; from_g += 1) {
- sweep_space(space_impure, from_g, {
- relocate_impure_help(pp, p, from_g);
- p = *(pp += 1);
- relocate_impure_help(pp, p, from_g);
- pp += 1;
- })
-
- sweep_space(space_symbol, from_g, {
- p = TYPE((ptr)pp, type_symbol);
- sweep_symbol(p, from_g ACTUAL_CTGS);
- pp += size_symbol / sizeof(ptr);
- })
-
- sweep_space(space_port, from_g, {
- p = TYPE((ptr)pp, type_typed_object);
- sweep_port(p, from_g ACTUAL_CTGS);
- pp += size_port / sizeof(ptr);
- })
-
- sweep_space(space_weakpair, from_g, {
- p = *(pp += 1);
- relocate_impure_help(pp, p, from_g);
- pp += 1;
- })
-
- sweep_space(space_ephemeron, from_g, {
- p = TYPE((ptr)pp, type_pair);
- add_ephemeron_to_pending(p);
- pp += size_ephemeron / sizeof(ptr);
- })
-
- sweep_space(space_pure, from_g, {
- relocate_pure_help(pp, p);
- p = *(pp += 1);
- relocate_pure_help(pp, p);
- pp += 1;
- })
-
- sweep_space(space_continuation, from_g, {
- p = TYPE((ptr)pp, type_closure);
- sweep_continuation(p ACTUAL_CTGS);
- pp += size_continuation / sizeof(ptr);
- })
-
- sweep_space(space_pure_typed_object, from_g, {
- p = TYPE((ptr)pp, type_typed_object);
- pp = (ptr *)((uptr)pp + sweep_typed_object(p, from_g ACTUAL_CTGS));
- })
-
- sweep_space(space_code, from_g, {
- p = TYPE((ptr)pp, type_typed_object);
- sweep_code_object(tc, p ACTUAL_CTGS);
- pp += size_code(CODELEN(p)) / sizeof(ptr);
- })
-
- sweep_space(space_impure_record, from_g, {
- p = TYPE((ptr)pp, type_typed_object);
- sweep_record(p, from_g ACTUAL_CTGS);
- pp = (ptr *)((iptr)pp +
- size_record_inst(UNFIX(RECORDDESCSIZE(RECORDINSTTYPE(p)))));
- })
- }
-
- /* Waiting until sweeping doesn't trigger a change reduces the
- chance that an ephemeron must be registered as a
- segment-specific trigger or gets triggered for recheck, but
- it doesn't change the worst-case complexity. */
- if (!change)
- check_pending_ephemerons(ONLY_ACTUAL_CTGS);
- } while (change);
-}
-
-#ifndef NO_LOCKED_OLDSPACE_OBJECTS
-static iptr size_object(ptr p) {
- ITYPE t; ptr tf;
-
- if ((t = TYPEBITS(p)) == type_pair) {
- seginfo *si;
- if ((si = MaybeSegInfo(ptr_get_segment(p))) != NULL && (si->space & ~(space_locked | space_old)) == space_ephemeron)
- return size_ephemeron;
- else
- return size_pair;
- } else if (t == type_closure) {
- ptr code = CLOSCODE(p);
- if (CODETYPE(code) & (code_flag_continuation << code_flags_offset))
- return size_continuation;
- else
- return size_closure(CLOSLEN(p));
- } else if (t == type_symbol) {
- return size_symbol;
- } else if (t == type_flonum) {
- return size_flonum;
- /* typed objects */
- } else if (tf = TYPEFIELD(p), TYPEP(tf, mask_vector, type_vector)) {
- return size_vector(Svector_length(p));
- } else if (TYPEP(tf, mask_string, type_string)) {
- return size_string(Sstring_length(p));
- } else if (TYPEP(tf, mask_bytevector, type_bytevector)) {
- return size_bytevector(Sbytevector_length(p));
- } else if (TYPEP(tf, mask_record, type_record)) {
- return size_record_inst(UNFIX(RECORDDESCSIZE(tf)));
- } else if (TYPEP(tf, mask_fxvector, type_fxvector)) {
- return size_fxvector(Sfxvector_length(p));
- } else if (TYPEP(tf, mask_box, type_box)) {
- return size_box;
- } else if ((iptr)tf == type_ratnum) {
- return size_ratnum;
- } else if ((iptr)tf == type_exactnum) {
- return size_exactnum;
- } else if ((iptr)tf == type_inexactnum) {
- return size_inexactnum;
- } else if (TYPEP(tf, mask_bignum, type_bignum)) {
- return size_bignum(BIGLEN(p));
- } else if (TYPEP(tf, mask_port, type_port)) {
- return size_port;
- } else if (TYPEP(tf, mask_code, type_code)) {
- return size_code(CODELEN(p));
- } else if ((iptr)tf == type_thread) {
- return size_thread;
- } else if ((iptr)tf == type_rtd_counts) {
- return size_rtd_counts;
- } else {
- S_error_abort("size_object(gc): illegal type");
- return 0 /* not reached */;
- }
-}
-#endif /* !NO_LOCKED_OLDSPACE_OBJECTS */
-
-static iptr sweep_typed_object(ptr p, IGEN from_g FORMAL_CTGS) {
- ptr tf = TYPEFIELD(p);
-
- if (TYPEP(tf, mask_record, type_record)) {
- sweep_record(p, from_g ACTUAL_CTGS);
- return size_record_inst(UNFIX(RECORDDESCSIZE(RECORDINSTTYPE(p))));
- } else if (TYPEP(tf, mask_thread, type_thread)) {
- sweep_thread(p ACTUAL_CTGS);
- return size_thread;
- } else {
- S_error_abort("sweep_typed_object(gc): unexpected type");
- return 0 /* not reached */;
- }
-}
-
-static void sweep_symbol(ptr p, IGEN from_g FORMAL_CTGS) {
- ptr val, code;
-
- relocate_impure(&INITSYMVAL(p), from_g);
- val = SYMVAL(p);
- code = Sprocedurep(val) ? CLOSCODE(val) : SYMCODE(p);
- relocate_pure(&code);
- INITSYMCODE(p,code);
- relocate_impure(&INITSYMPLIST(p), from_g);
- relocate_impure(&INITSYMSPLIST(p), from_g);
- relocate_impure(&INITSYMNAME(p), from_g);
- relocate_impure(&INITSYMHASH(p), from_g);
-}
-
-static void sweep_port(ptr p, IGEN from_g FORMAL_CTGS) {
- relocate_impure(&PORTHANDLER(p), from_g);
- relocate_impure(&PORTINFO(p), from_g);
- relocate_impure(&PORTNAME(p), from_g);
-
- if (PORTTYPE(p) & PORT_FLAG_OUTPUT) {
- iptr n = (iptr)PORTOLAST(p) - (iptr)PORTOBUF(p);
- relocate_impure(&PORTOBUF(p), from_g);
- PORTOLAST(p) = (ptr)((iptr)PORTOBUF(p) + n);
- }
-
- if (PORTTYPE(p) & PORT_FLAG_INPUT) {
- iptr n = (iptr)PORTILAST(p) - (iptr)PORTIBUF(p);
- relocate_impure(&PORTIBUF(p), from_g);
- PORTILAST(p) = (ptr)((iptr)PORTIBUF(p) + n);
- }
-}
-
-static void sweep_thread(ptr p FORMAL_CTGS) {
- ptr tc = (ptr)THREADTC(p);
- INT i;
-
- if (tc != (ptr)0) {
- ptr old_stack = SCHEMESTACK(tc);
- if (OLDSPACE(old_stack)) {
- iptr clength = (uptr)SFP(tc) - (uptr)old_stack;
- /* include SFP[0], which contains the return address */
- SCHEMESTACK(tc) = copy_stack(old_stack, &SCHEMESTACKSIZE(tc), clength + sizeof(ptr) ACTUAL_CTGS);
- SFP(tc) = (ptr)((uptr)SCHEMESTACK(tc) + clength);
- ESP(tc) = (ptr)((uptr)SCHEMESTACK(tc) + SCHEMESTACKSIZE(tc) - stack_slop);
- }
- STACKCACHE(tc) = Snil;
- relocate_pure(&CCHAIN(tc));
- /* U32 RANDOMSEED(tc) */
- /* I32 ACTIVE(tc) */
- relocate_pure(&STACKLINK(tc));
- /* iptr SCHEMESTACKSIZE */
- relocate_pure(&WINDERS(tc));
- relocate_return_addr(&FRAME(tc,0));
- sweep_stack((uptr)SCHEMESTACK(tc), (uptr)SFP(tc), (uptr)FRAME(tc,0) ACTUAL_CTGS);
- U(tc) = V(tc) = W(tc) = X(tc) = Y(tc) = 0;
- /* immediate SOMETHINGPENDING(tc) */
- /* immediate TIMERTICKS */
- /* immediate DISABLE_COUNT */
- /* immediate SIGNALINTERRUPTPENDING */
- /* void* SIGNALINTERRUPTQUEUE(tc) */
- /* immediate KEYBOARDINTERRUPTPENDING */
- relocate_pure(&THREADNO(tc));
- relocate_pure(&CURRENTINPUT(tc));
- relocate_pure(&CURRENTOUTPUT(tc));
- relocate_pure(&CURRENTERROR(tc));
- /* immediate BLOCKCOUNTER */
- relocate_pure(&SFD(tc));
- relocate_pure(&CURRENTMSO(tc));
- relocate_pure(&TARGETMACHINE(tc));
- relocate_pure(&FXLENGTHBV(tc));
- relocate_pure(&FXFIRSTBITSETBV(tc));
- relocate_pure(&NULLIMMUTABLEVECTOR(tc));
- relocate_pure(&NULLIMMUTABLEFXVECTOR(tc));
- relocate_pure(&NULLIMMUTABLEBYTEVECTOR(tc));
- relocate_pure(&NULLIMMUTABLESTRING(tc));
- /* immediate METALEVEL */
- relocate_pure(&COMPILEPROFILE(tc));
- /* immediate GENERATEINSPECTORINFORMATION */
- /* immediate GENERATEPROFILEFORMS */
- /* immediate OPTIMIZELEVEL */
- relocate_pure(&SUBSETMODE(tc));
- /* immediate SUPPRESSPRIMITIVEINLINING */
- relocate_pure(&DEFAULTRECORDEQUALPROCEDURE(tc));
- relocate_pure(&DEFAULTRECORDHASHPROCEDURE(tc));
- relocate_pure(&COMPRESSFORMAT(tc));
- relocate_pure(&COMPRESSLEVEL(tc));
- /* void* LZ4OUTBUFFER(tc) */
- /* U64 INSTRCOUNTER(tc) */
- /* U64 ALLOCCOUNTER(tc) */
- relocate_pure(&PARAMETERS(tc));
- for (i = 0 ; i < virtual_register_count ; i += 1) {
- relocate_pure(&VIRTREG(tc, i));
- }
- DSTBV(tc) = SRCBV(tc) = Sfalse;
- }
-}
-
-static void sweep_continuation(ptr p FORMAL_CTGS) {
- relocate_pure(&CONTWINDERS(p));
-
- /* bug out for shot 1-shot continuations */
- if (CONTLENGTH(p) == scaled_shot_1_shot_flag) return;
-
- if (OLDSPACE(CONTSTACK(p)))
- CONTSTACK(p) = copy_stack(CONTSTACK(p), &CONTLENGTH(p), CONTCLENGTH(p) ACTUAL_CTGS);
-
- relocate_pure(&CONTLINK(p));
- relocate_return_addr(&CONTRET(p));
-
- /* use CLENGTH to avoid sweeping unoccupied portion of one-shots */
- sweep_stack((uptr)CONTSTACK(p), (uptr)CONTSTACK(p) + CONTCLENGTH(p), (uptr)CONTRET(p) ACTUAL_CTGS);
-}
-
-/* assumes stack has already been copied to newspace */
-static void sweep_stack(uptr base, uptr fp, uptr ret FORMAL_CTGS) {
- ptr *pp; iptr oldret;
- ptr num;
-
- while (fp != base) {
- if (fp < base)
- S_error_abort("sweep_stack(gc): malformed stack");
- fp = fp - ENTRYFRAMESIZE(ret);
- pp = (ptr *)fp;
-
- oldret = ret;
- ret = (iptr)(*pp);
- relocate_return_addr(pp);
-
- num = ENTRYLIVEMASK(oldret);
- if (Sfixnump(num)) {
- uptr mask = UNFIX(num);
- while (mask != 0) {
- pp += 1;
- if (mask & 0x0001) relocate_pure(pp);
- mask >>= 1;
- }
- } else {
- iptr index;
-
- relocate_pure(&ENTRYLIVEMASK(oldret));
- num = ENTRYLIVEMASK(oldret);
- index = BIGLEN(num);
- while (index-- != 0) {
- INT bits = bigit_bits;
- bigit mask = BIGIT(num,index);
- while (bits-- > 0) {
- pp += 1;
- if (mask & 1) relocate_pure(pp);
- mask >>= 1;
- }
- }
- }
- }
-}
-
-static void sweep_record(ptr x, IGEN from_g FORMAL_CTGS) {
- ptr *pp; ptr num; ptr rtd;
-
- /* record-type descriptor was forwarded in copy */
- rtd = RECORDINSTTYPE(x);
- num = RECORDDESCPM(rtd);
- pp = &RECORDINSTIT(x,0);
-
- /* sweep cells for which bit in pm is set; quit when pm == 0. */
- if (Sfixnump(num)) {
- /* ignore bit for already forwarded rtd */
- uptr mask = (uptr)UNFIX(num) >> 1;
- if (mask == (uptr)-1 >> 1) {
- ptr *ppend = (ptr *)((uptr)pp + UNFIX(RECORDDESCSIZE(rtd))) - 1;
- while (pp < ppend) {
- relocate_impure(pp, from_g);
- pp += 1;
- }
- } else {
- while (mask != 0) {
- if (mask & 1) { relocate_impure(pp, from_g); }
- mask >>= 1;
- pp += 1;
- }
- }
- } else {
- iptr index; bigit mask; INT bits;
-
- /* bignum pointer mask may have been forwarded */
- relocate_pure(&RECORDDESCPM(rtd));
- num = RECORDDESCPM(rtd);
- index = BIGLEN(num) - 1;
- /* ignore bit for already forwarded rtd */
- mask = BIGIT(num,index) >> 1;
- bits = bigit_bits - 1;
- for (;;) {
- do {
- if (mask & 1) { relocate_impure(pp, from_g); }
- mask >>= 1;
- pp += 1;
- } while (--bits > 0);
- if (index-- == 0) break;
- mask = BIGIT(num,index);
- bits = bigit_bits;
- }
- }
-}
-
-static IGEN sweep_dirty_record(ptr x, IGEN youngest FORMAL_CTGS) {
- ptr *pp; ptr num; ptr rtd;
-
- /* warning: assuming rtd is immutable */
- rtd = RECORDINSTTYPE(x);
-
- /* warning: assuming MPM field is immutable */
- num = RECORDDESCMPM(rtd);
- pp = &RECORDINSTIT(x,0);
-
- /* sweep cells for which bit in mpm is set */
- if (Sfixnump(num)) {
- /* ignore bit for assumed immutable rtd */
- uptr mask = (uptr)UNFIX(num) >> 1;
- while (mask != 0) {
- if (mask & 1) relocate_dirty(pp, youngest);
- mask >>= 1;
- pp += 1;
- }
- } else {
- iptr index; bigit mask; INT bits;
-
- index = BIGLEN(num) - 1;
- /* ignore bit for assumed immutable rtd */
- mask = BIGIT(num,index) >> 1;
- bits = bigit_bits - 1;
- for (;;) {
- do {
- if (mask & 1) relocate_dirty(pp, youngest);
- mask >>= 1;
- pp += 1;
- } while (--bits > 0);
- if (index-- == 0) break;
- mask = BIGIT(num,index);
- bits = bigit_bits;
- }
- }
-
- return youngest;
-}
-
-static void sweep_code_object(ptr tc, ptr co FORMAL_CTGS) {
- ptr t, oldco; iptr a, m, n;
-
-#ifdef DEBUG
- if ((CODETYPE(co) & mask_code) != type_code) {
- (void)printf("unexpected type %x sweeping code object %p\n", CODETYPE(co), co);
- (void)fflush(stdout);
- }
-#endif
-
- relocate_pure(&CODENAME(co));
- relocate_pure(&CODEARITYMASK(co));
- relocate_pure(&CODEINFO(co));
- relocate_pure(&CODEPINFOS(co));
-
- t = CODERELOC(co);
- m = RELOCSIZE(t);
- oldco = RELOCCODE(t);
- a = 0;
- n = 0;
- while (n < m) {
- uptr entry, item_off, code_off; ptr obj;
- entry = RELOCIT(t, n); n += 1;
- if (RELOC_EXTENDED_FORMAT(entry)) {
- item_off = RELOCIT(t, n); n += 1;
- code_off = RELOCIT(t, n); n += 1;
- } else {
- item_off = RELOC_ITEM_OFFSET(entry);
- code_off = RELOC_CODE_OFFSET(entry);
- }
- a += code_off;
- obj = S_get_code_obj(RELOC_TYPE(entry), oldco, a, item_off);
- relocate_pure(&obj);
- S_set_code_obj("gc", RELOC_TYPE(entry), co, a, obj, item_off);
- }
-
- /* Don't copy non-oldspace relocation tables, since we may be
- sweeping a locked code object that is older than max_target_generation
- Doing so would be a waste of work anyway. */
- if (OLDSPACE(t)) {
- IGEN newg = compute_target_generation(GENERATION(t) ACTUAL_CTGS);
- if (newg == static_generation && !S_G.retain_static_relocation && (CODETYPE(co) & (code_flag_template << code_flags_offset)) == 0) {
- CODERELOC(co) = (ptr)0;
- } else {
- ptr oldt = t;
- n = size_reloc_table(RELOCSIZE(oldt));
-#ifdef ENABLE_OBJECT_COUNTS
- S_G.countof[newg][countof_relocation_table] += 1;
- S_G.bytesof[newg][countof_relocation_table] += n;
-#endif /* ENABLE_OBJECT_COUNTS */
- find_room(space_data, newg, typemod, n, t);
- copy_ptrs(typemod, t, oldt, n);
- RELOCCODE(t) = co;
- CODERELOC(co) = t;
- }
- } else {
- RELOCCODE(t) = co;
- }
-
- S_record_code_mod(tc, (uptr)&CODEIT(co,0), (uptr)CODELEN(co));
-}
-
-typedef struct _weakseginfo {
- seginfo *si;
- IGEN youngest[cards_per_segment];
- struct _weakseginfo *next;
-} weakseginfo;
-
-static weakseginfo *weaksegments_to_resweep;
-
-static void record_dirty_segment(IGEN from_g, IGEN to_g, seginfo *si) {
- if (si->min_dirty_byte != 0xff) {
- S_error_abort("record_dirty(gc): unexpected mutation while sweeping");
- }
-
- if (to_g < from_g) {
- seginfo *oldfirst = DirtySegments(from_g, to_g);
- DirtySegments(from_g, to_g) = si;
- si->dirty_prev = &DirtySegments(from_g, to_g);
- si->dirty_next = oldfirst;
- if (oldfirst != NULL) oldfirst->dirty_prev = &si->dirty_next;
- si->min_dirty_byte = to_g;
- }
-}
-
-static void sweep_dirty(ONLY_FORMAL_CTGS) {
- IGEN youngest, min_youngest;
- ptr *pp, *ppend, *nl;
- uptr seg, d;
- ISPC s;
- IGEN from_g, to_g;
- seginfo *dirty_si, *nextsi;
-
- weaksegments_to_resweep = NULL;
-
- /* clear dirty segment lists for copied generations */
- for (from_g = 1; from_g <= MAX_CG; from_g += 1) {
- for (to_g = 0; to_g < from_g; to_g += 1) {
- DirtySegments(from_g, to_g) = NULL;
- }
- }
-
- /* NB: could have problems if a card is moved from some current or to-be-swept (from_g, to_g) to some previously
- swept list due to a dirty_set while we sweep. believe this can't happen as of 6/14/2013. if it can, it
- might be sufficient to process the lists in reverse order. */
- for (from_g = MAX_CG + 1; from_g <= static_generation; INCRGEN(from_g)) {
- for (to_g = 0; to_g <= MAX_CG; to_g += 1) {
- for (dirty_si = DirtySegments(from_g, to_g), DirtySegments(from_g, to_g) = NULL; dirty_si != NULL; dirty_si = nextsi) {
- nextsi = dirty_si->dirty_next;
- seg = dirty_si->number;
- s = dirty_si->space;
-
- if (s & space_locked) continue;
-
- /* reset min dirty byte so we can detect if byte is set while card is swept */
- dirty_si->min_dirty_byte = 0xff;
-
- min_youngest = 0xff;
- nl = from_g == MAX_TG ? (ptr *)orig_next_loc[from_g][s] : (ptr *)S_G.next_loc[from_g][s];
- ppend = build_ptr(seg, 0);
-
- if (s == space_weakpair) {
- weakseginfo *next = weaksegments_to_resweep;
- find_room(space_data, 0, typemod, ptr_align(sizeof(weakseginfo)), weaksegments_to_resweep);
- weaksegments_to_resweep->si = dirty_si;
- weaksegments_to_resweep->next = next;
- }
-
- d = 0;
- while (d < cards_per_segment) {
- uptr dend = d + sizeof(iptr);
- iptr *dp = (iptr *)(dirty_si->dirty_bytes + d);
- /* check sizeof(iptr) bytes at a time for 0xff */
- if (*dp == -1) {
- pp = ppend;
- ppend += bytes_per_card;
- if (pp <= nl && nl < ppend) ppend = nl;
- d = dend;
- } else {
- while (d < dend) {
- pp = ppend;
- ppend += bytes_per_card / sizeof(ptr);
- if (pp <= nl && nl < ppend) ppend = nl;
-
- if (dirty_si->dirty_bytes[d] <= MAX_CG) {
- /* assume we won't find any wrong-way pointers */
- youngest = 0xff;
-
- if (s == space_impure) {
- while (pp < ppend && *pp != forward_marker) {
- /* handle two pointers at a time */
- relocate_dirty(pp, youngest);
- pp += 1;
- relocate_dirty(pp, youngest);
- pp += 1;
- }
- } else if (s == space_symbol) {
- /* old symbols cannot overlap segment boundaries
- since any object that spans multiple
- generations begins at the start of a segment,
- and symbols are much smaller (we assume)
- than the segment size. */
- pp = (ptr *)build_ptr(seg,0) +
- ((pp - (ptr *)build_ptr(seg,0)) /
- (size_symbol / sizeof(ptr))) *
- (size_symbol / sizeof(ptr));
-
- while (pp < ppend && *pp != forward_marker) { /* might overshoot card by part of a symbol. no harm. */
- ptr p, val, code;
-
- p = TYPE((ptr)pp, type_symbol);
-
- val = SYMVAL(p);
- relocate_dirty(&val, youngest);
- INITSYMVAL(p) = val;
- code = Sprocedurep(val) ? CLOSCODE(val) : SYMCODE(p);
- relocate_dirty(&code, youngest);
- INITSYMCODE(p,code);
- relocate_dirty(&INITSYMPLIST(p), youngest);
- relocate_dirty(&INITSYMSPLIST(p), youngest);
- relocate_dirty(&INITSYMNAME(p), youngest);
- relocate_dirty(&INITSYMHASH(p), youngest);
-
- pp += size_symbol / sizeof(ptr);
- }
- } else if (s == space_port) {
- /* old ports cannot overlap segment boundaries
- since any object that spans multiple
- generations begins at the start of a segment,
- and ports are much smaller (we assume)
- than the segment size. */
- pp = (ptr *)build_ptr(seg,0) +
- ((pp - (ptr *)build_ptr(seg,0)) /
- (size_port / sizeof(ptr))) *
- (size_port / sizeof(ptr));
-
- while (pp < ppend && *pp != forward_marker) { /* might overshoot card by part of a port. no harm. */
- ptr p = TYPE((ptr)pp, type_typed_object);
-
- relocate_dirty(&PORTHANDLER(p), youngest);
- relocate_dirty(&PORTINFO(p), youngest);
- relocate_dirty(&PORTNAME(p), youngest);
-
- if (PORTTYPE(p) & PORT_FLAG_OUTPUT) {
- iptr n = (iptr)PORTOLAST(p) - (iptr)PORTOBUF(p);
- relocate_dirty(&PORTOBUF(p), youngest);
- PORTOLAST(p) = (ptr)((iptr)PORTOBUF(p) + n);
- }
-
- if (PORTTYPE(p) & PORT_FLAG_INPUT) {
- iptr n = (iptr)PORTILAST(p) - (iptr)PORTIBUF(p);
- relocate_dirty(&PORTIBUF(p), youngest);
- PORTILAST(p) = (ptr)((iptr)PORTIBUF(p) + n);
- }
-
- pp += size_port / sizeof(ptr);
- }
- } else if (s == space_impure_record) { /* abandon hope all ye who enter here */
- uptr j; ptr p, pnext; seginfo *si;
-
- /* synchronize on first record that overlaps the dirty
- area, then relocate any mutable pointers in that
- record and those that follow within the dirty area. */
-
- /* find first segment of group of like segments */
- j = seg - 1;
- while ((si = MaybeSegInfo(j)) != NULL &&
- si->space == s &&
- si->generation == from_g)
- j -= 1;
- j += 1;
-
- /* now find first record in segment seg */
- /* we count on following fact: if an object spans two
- or more segments, then he starts at the beginning
- of a segment */
- for (;;) {
- p = TYPE(build_ptr(j,0),type_typed_object);
- pnext = (ptr)((iptr)p +
- size_record_inst(UNFIX(RECORDDESCSIZE(
- RECORDINSTTYPE(p)))));
- if (ptr_get_segment(pnext) >= seg) break;
- j = ptr_get_segment(pnext) + 1;
- }
-
- /* now find first within dirty area */
- while ((ptr *)UNTYPE(pnext, type_typed_object) <= pp) {
- p = pnext;
- pnext = (ptr)((iptr)p +
- size_record_inst(UNFIX(RECORDDESCSIZE(
- RECORDINSTTYPE(p)))));
- }
-
- /* now sweep */
- while ((ptr *)UNTYPE(p, type_typed_object) < ppend) {
- /* quit on end of segment */
- if (FWDMARKER(p) == forward_marker) break;
-
- youngest = sweep_dirty_record(p, youngest ACTUAL_CTGS);
- p = (ptr)((iptr)p +
- size_record_inst(UNFIX(RECORDDESCSIZE(
- RECORDINSTTYPE(p)))));
- }
- } else if (s == space_weakpair) {
- while (pp < ppend && *pp != forward_marker) {
- /* skip car field and handle cdr field */
- pp += 1;
- relocate_dirty(pp, youngest);
- pp += 1;
- }
- } else if (s == space_ephemeron) {
- while (pp < ppend && *pp != forward_marker) {
- ptr p = TYPE((ptr)pp, type_pair);
- youngest = check_dirty_ephemeron(p, youngest ACTUAL_CTGS);
- pp += size_ephemeron / sizeof(ptr);
- }
- } else {
- S_error_abort("sweep_dirty(gc): unexpected space");
- }
-
- if (s == space_weakpair) {
- weaksegments_to_resweep->youngest[d] = youngest;
- } else {
- dirty_si->dirty_bytes[d] = youngest < from_g ? youngest : 0xff;
- }
- if (youngest < min_youngest) min_youngest = youngest;
- } else {
- if (dirty_si->dirty_bytes[d] < min_youngest) min_youngest = dirty_si->dirty_bytes[d];
- }
- d += 1;
- }
- }
- }
- if (s != space_weakpair) {
- record_dirty_segment(from_g, min_youngest, dirty_si);
- }
- }
- }
- }
-}
-
-static void resweep_dirty_weak_pairs(ONLY_FORMAL_CTGS) {
- weakseginfo *ls;
- ptr *pp, *ppend, *nl, p;
- IGEN from_g, min_youngest, youngest, pg, newpg;
- uptr d;
-
- for (ls = weaksegments_to_resweep; ls != NULL; ls = ls->next) {
- seginfo *dirty_si = ls->si;
- from_g = dirty_si->generation;
- nl = from_g == MAX_TG ? (ptr *)orig_next_loc[from_g][space_weakpair] : (ptr *)S_G.next_loc[from_g][space_weakpair];
- ppend = build_ptr(dirty_si->number, 0);
- min_youngest = 0xff;
- d = 0;
- while (d < cards_per_segment) {
- uptr dend = d + sizeof(iptr);
- iptr *dp = (iptr *)(dirty_si->dirty_bytes + d);
- /* check sizeof(iptr) bytes at a time for 0xff */
- if (*dp == -1) {
- d = dend;
- ppend += bytes_per_card;
- } else {
- while (d < dend) {
- pp = ppend;
- ppend += bytes_per_card / sizeof(ptr);
- if (pp <= nl && nl < ppend) ppend = nl;
- if (dirty_si->dirty_bytes[d] <= MAX_CG) {
- youngest = ls->youngest[d];
- while (pp < ppend) {
- p = *pp;
- seginfo *si;
-
- /* handle car field */
- if (!IMMEDIATE(p) && (si = MaybeSegInfo(ptr_get_segment(p))) != NULL) {
- pg = si->generation;
- newpg = compute_target_generation(pg ACTUAL_CTGS);
- if (si->space & space_old) {
- if (locked(p)) {
- if (newpg < youngest) youngest = newpg;
- } else if (FWDMARKER(p) == forward_marker && TYPEBITS(p) != type_flonum) {
- *pp = FWDADDRESS(p);
- if (newpg < youngest) youngest = newpg;
- } else {
- *pp = Sbwp_object;
- }
- } else {
- if (pg < youngest) youngest = pg;
- }
- }
-
- /* skip cdr field */
- pp += 2;
- }
-
- dirty_si->dirty_bytes[d] = youngest < from_g ? youngest : 0xff;
- if (youngest < min_youngest) min_youngest = youngest;
- } else {
- if (dirty_si->dirty_bytes[d] < min_youngest) min_youngest = dirty_si->dirty_bytes[d];
- }
- d += 1;
- }
- }
- }
- record_dirty_segment(from_g, min_youngest, dirty_si);
- }
-}
-
-static ptr pending_ephemerons = NULL;
-/* Ephemerons that we haven't looked at, chained through `next`. */
-
-static ptr trigger_ephemerons = NULL;
-/* Ephemerons that we've checked and added to segment triggers,
- chained through `next`. Ephemerons attached to a segment are
- chained through `trigger-next`. A #t in `trigger-next` means that
- the ephemeron has been processed, so we don't need to remove it
- from the trigger list in a segment. */
-
-static ptr repending_ephemerons = NULL;
-/* Ephemerons in `trigger_ephemerons` that we need to inspect again,
- removed from the triggering segment and chained here through
- `trigger-next`. */
-
-static void add_ephemeron_to_pending(ptr pe) {
- /* We could call check_ephemeron directly here, but the indirection
- through `pending_ephemerons` can dramatically decrease the number
- of times that we have to trigger re-checking, especially since
- check_pending_pehemerons() is run only after all other sweep
- opportunities are exhausted. */
- EPHEMERONNEXT(pe) = pending_ephemerons;
- pending_ephemerons = pe;
-}
-
-static void add_trigger_ephemerons_to_repending(ptr pe) {
- ptr last_pe = pe, next_pe = EPHEMERONTRIGGERNEXT(pe);
- while (next_pe != NULL) {
- last_pe = next_pe;
- next_pe = EPHEMERONTRIGGERNEXT(next_pe);
- }
- EPHEMERONTRIGGERNEXT(last_pe) = repending_ephemerons;
- repending_ephemerons = pe;
-}
-
-static void check_ephemeron(ptr pe, IBOOL add_to_trigger FORMAL_CTGS) {
- ptr p;
- seginfo *si;
- IGEN from_g = GENERATION(pe);
-
- p = Scar(pe);
- if (!IMMEDIATE(p) && (si = MaybeSegInfo(ptr_get_segment(p))) != NULL && si->space & space_old && !locked(p)) {
- if (FWDMARKER(p) == forward_marker && TYPEBITS(p) != type_flonum) {
-#ifndef NO_DIRTY_NEWSPACE_POINTERS
- IGEN pg = compute_target_generation(si->generation ACTUAL_CTGS);
- if (pg < from_g) record_new_dirty_card(&INITCAR(pe), pg);
-#endif
- INITCAR(pe) = FWDADDRESS(p);
- relocate_impure(&INITCDR(pe), from_g);
- if (!add_to_trigger)
- EPHEMERONTRIGGERNEXT(pe) = Strue; /* in trigger list, #t means "done" */
- } else {
- /* Not reached, so far; install as trigger */
- EPHEMERONTRIGGERNEXT(pe) = si->trigger_ephemerons;
- si->trigger_ephemerons = pe;
- if (add_to_trigger) {
- EPHEMERONNEXT(pe) = trigger_ephemerons;
- trigger_ephemerons = pe;
- }
- }
- } else {
- relocate_impure(&INITCDR(pe), from_g);
- }
-}
-
-static void check_pending_ephemerons(ONLY_FORMAL_CTGS) {
- ptr pe, next_pe;
-
- pe = pending_ephemerons;
- pending_ephemerons = NULL;
- while (pe != NULL) {
- next_pe = EPHEMERONNEXT(pe);
- check_ephemeron(pe, 1 ACTUAL_CTGS);
- pe = next_pe;
- }
-
- pe = repending_ephemerons;
- repending_ephemerons = NULL;
- while (pe != NULL) {
- next_pe = EPHEMERONTRIGGERNEXT(pe);
- check_ephemeron(pe, 0 ACTUAL_CTGS);
- pe = next_pe;
- }
-}
-
-/* Like check_ephemeron(), but for a dirty, old-generation
- ephemeron (that was not yet added to the pending list), so we can
- be less pessimistic than setting `youngest` to the target
- generation: */
-static IGEN check_dirty_ephemeron(ptr pe, IGEN youngest FORMAL_CTGS) {
- ptr p;
- seginfo *si;
- IGEN pg;
-
- p = Scar(pe);
- if (!IMMEDIATE(p) && (si = MaybeSegInfo(ptr_get_segment(p))) != NULL) {
- if (si->space & space_old && !locked(p)) {
- if (FWDMARKER(p) == forward_marker && TYPEBITS(p) != type_flonum) {
- INITCAR(pe) = FWDADDRESS(p);
- if (youngest != MIN_TG && (pg = compute_target_generation(si->generation ACTUAL_CTGS)) < youngest)
- youngest = pg;
- relocate_dirty(&INITCDR(pe), youngest);
- } else {
- /* Not reached, so far; add to pending list */
- add_ephemeron_to_pending(pe);
- /* Make the consistent (but pessimistic w.r.t. to wrong-way
- pointers) assumption that the key will stay live and move
- to the target generation. That assumption covers the value
- part, too, since it can't end up younger than the target
- generation. */
- if (youngest != MIN_TG && (pg = compute_target_generation(si->generation ACTUAL_CTGS)) < youngest)
- youngest = pg;
- }
- } else {
- if (youngest != MIN_TG && (pg = si->generation) < youngest)
- youngest = pg;
- relocate_dirty(&INITCDR(pe), youngest);
- }
- } else {
- /* Non-collectable key means that the value determines
- `youngest`: */
- relocate_dirty(&INITCDR(pe), youngest);
- }
-
- return youngest;
-}
-
-static void clear_trigger_ephemerons(void) {
- ptr pe;
-
- if (pending_ephemerons != NULL)
- S_error_abort("clear_trigger_ephemerons(gc): non-empty pending list");
-
- pe = trigger_ephemerons;
- trigger_ephemerons = NULL;
- while (pe != NULL) {
- if (EPHEMERONTRIGGERNEXT(pe) == Strue) {
- /* The ephemeron was triggered and retains its key and value */
- } else {
- seginfo *si;
- ptr p = Scar(pe);
- /* Key never became reachable, so clear key and value */
- INITCAR(pe) = Sbwp_object;
- INITCDR(pe) = Sbwp_object;
-
- /* Remove trigger */
- si = SegInfo(ptr_get_segment(p));
- si->trigger_ephemerons = NULL;
- }
- pe = EPHEMERONNEXT(pe);
- }
-}
diff --git a/ta6ob/c/gcwrapper.c b/ta6ob/c/gcwrapper.c
deleted file mode 100644
index f00f9cd..0000000
--- a/ta6ob/c/gcwrapper.c
+++ /dev/null
@@ -1,864 +0,0 @@
-/* gcwrapper.c
- * Copyright 1984-2017 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.
- */
-
-#include "system.h"
-
-/* locally defined functions */
-static IBOOL memqp(ptr x, ptr ls);
-static IBOOL remove_first_nomorep(ptr x, ptr *pls, IBOOL look);
-static void segment_tell(uptr seg);
-static void check_heap_dirty_msg(char *msg, ptr *x);
-static IBOOL dirty_listedp(seginfo *x, IGEN from_g, IGEN to_g);
-static void check_dirty_space(ISPC s);
-static void check_dirty(void);
-
-static IBOOL checkheap_noisy;
-
-void S_gc_init(void) {
- IGEN g; INT i;
-
- S_checkheap = 0; /* 0 for disabled, 1 for enabled */
- S_checkheap_errors = 0; /* count of errors detected by checkheap */
- checkheap_noisy = 0; /* 0 for error output only; 1 for more noisy output */
- S_G.prcgeneration = static_generation;
-
- if (S_checkheap) {
- printf(checkheap_noisy ? "NB: check_heap is enabled and noisy\n" : "NB: check_heap_is_enabled\n");
- fflush(stdout);
- }
-
-#ifndef WIN32
- for (g = 0; g <= static_generation; g++) {
- S_child_processes[g] = Snil;
- }
-#endif /* WIN32 */
-
- if (!S_boot_time) return;
-
- for (g = 0; g <= static_generation; g++) {
- S_G.guardians[g] = Snil;
- S_G.locked_objects[g] = Snil;
- S_G.unlocked_objects[g] = Snil;
- }
- S_G.max_nonstatic_generation =
- S_G.new_max_nonstatic_generation =
- S_G.min_free_gen =
- S_G.new_min_free_gen = default_max_nonstatic_generation;
-
- for (g = 0; g <= static_generation; g += 1) {
- for (i = 0; i < countof_types; i += 1) {
- S_G.countof[g][i] = 0;
- S_G.bytesof[g][i] = 0;
- }
- S_G.gctimestamp[g] = 0;
- S_G.rtds_with_counts[g] = Snil;
- }
-
- S_G.countof[static_generation][countof_oblist] += 1;
- S_G.bytesof[static_generation][countof_oblist] += S_G.oblist_length * sizeof(bucket *);
-
- S_protect(&S_G.static_id);
- S_G.static_id = S_intern((const unsigned char *)"static");
-
- S_protect(&S_G.countof_names);
- S_G.countof_names = S_vector(countof_types);
- for (i = 0; i < countof_types; i += 1) {
- INITVECTIT(S_G.countof_names, i) = FIX(0);
- S_G.countof_size[i] = 0;
- }
- INITVECTIT(S_G.countof_names, countof_pair) = S_intern((const unsigned char *)"pair");
- S_G.countof_size[countof_pair] = size_pair;
- INITVECTIT(S_G.countof_names, countof_symbol) = S_intern((const unsigned char *)"symbol");
- S_G.countof_size[countof_symbol] = size_symbol;
- INITVECTIT(S_G.countof_names, countof_flonum) = S_intern((const unsigned char *)"flonum");
- S_G.countof_size[countof_flonum] = size_flonum;
- INITVECTIT(S_G.countof_names, countof_closure) = S_intern((const unsigned char *)"procedure");
- S_G.countof_size[countof_closure] = 0;
- INITVECTIT(S_G.countof_names, countof_continuation) = S_intern((const unsigned char *)"continuation");
- S_G.countof_size[countof_continuation] = size_continuation;
- INITVECTIT(S_G.countof_names, countof_bignum) = S_intern((const unsigned char *)"bignum");
- S_G.countof_size[countof_bignum] = 0;
- INITVECTIT(S_G.countof_names, countof_ratnum) = S_intern((const unsigned char *)"ratnum");
- S_G.countof_size[countof_ratnum] = size_ratnum;
- INITVECTIT(S_G.countof_names, countof_inexactnum) = S_intern((const unsigned char *)"inexactnum");
- S_G.countof_size[countof_inexactnum] = size_inexactnum;
- INITVECTIT(S_G.countof_names, countof_exactnum) = S_intern((const unsigned char *)"exactnum");
- S_G.countof_size[countof_exactnum] = size_exactnum;
- INITVECTIT(S_G.countof_names, countof_box) = S_intern((const unsigned char *)"box");
- S_G.countof_size[countof_box] = size_box;
- INITVECTIT(S_G.countof_names, countof_port) = S_intern((const unsigned char *)"port");
- S_G.countof_size[countof_port] = size_port;
- INITVECTIT(S_G.countof_names, countof_code) = S_intern((const unsigned char *)"code");
- S_G.countof_size[countof_code] = 0;
- INITVECTIT(S_G.countof_names, countof_thread) = S_intern((const unsigned char *)"thread");
- S_G.countof_size[countof_thread] = size_thread;
- INITVECTIT(S_G.countof_names, countof_tlc) = S_intern((const unsigned char *)"tlc");
- S_G.countof_size[countof_tlc] = size_tlc;
- INITVECTIT(S_G.countof_names, countof_rtd_counts) = S_intern((const unsigned char *)"rtd-counts");
- S_G.countof_size[countof_rtd_counts] = size_rtd_counts;
- INITVECTIT(S_G.countof_names, countof_stack) = S_intern((const unsigned char *)"stack");
- S_G.countof_size[countof_stack] = 0;
- INITVECTIT(S_G.countof_names, countof_relocation_table) = S_intern((const unsigned char *)"reloc-table");
- S_G.countof_size[countof_relocation_table] = 0;
- INITVECTIT(S_G.countof_names, countof_weakpair) = S_intern((const unsigned char *)"weakpair");
- S_G.countof_size[countof_weakpair] = size_pair;
- INITVECTIT(S_G.countof_names, countof_vector) = S_intern((const unsigned char *)"vector");
- S_G.countof_size[countof_vector] = 0;
- INITVECTIT(S_G.countof_names, countof_string) = S_intern((const unsigned char *)"string");
- S_G.countof_size[countof_string] = 0;
- INITVECTIT(S_G.countof_names, countof_fxvector) = S_intern((const unsigned char *)"fxvector");
- S_G.countof_size[countof_fxvector] = 0;
- INITVECTIT(S_G.countof_names, countof_bytevector) = S_intern((const unsigned char *)"bytevector");
- S_G.countof_size[countof_bytevector] = 0;
- INITVECTIT(S_G.countof_names, countof_locked) = S_intern((const unsigned char *)"locked");
- S_G.countof_size[countof_locked] = 0;
- INITVECTIT(S_G.countof_names, countof_guardian) = S_intern((const unsigned char *)"guardian");
- S_G.countof_size[countof_guardian] = size_guardian_entry;
- INITVECTIT(S_G.countof_names, countof_oblist) = S_intern((const unsigned char *)"oblist");
- S_G.countof_size[countof_guardian] = 0;
- INITVECTIT(S_G.countof_names, countof_ephemeron) = S_intern((const unsigned char *)"ephemron");
- S_G.countof_size[countof_ephemeron] = 0;
- for (i = 0; i < countof_types; i += 1) {
- if (Svector_ref(S_G.countof_names, i) == FIX(0)) {
- fprintf(stderr, "uninitialized countof_name at index %d\n", i);
- S_abnormal_exit();
- }
- }
-}
-
-IGEN S_maxgen(void) {
- return S_G.new_max_nonstatic_generation;
-}
-
-void S_set_maxgen(IGEN g) {
- if (g < 0 || g >= static_generation) {
- fprintf(stderr, "invalid maxgen %d\n", g);
- S_abnormal_exit();
- }
- if (S_G.new_min_free_gen == S_G.new_max_nonstatic_generation || S_G.new_min_free_gen > g) {
- S_G.new_min_free_gen = g;
- }
- S_G.new_max_nonstatic_generation = g;
-}
-
-IGEN S_minfreegen(void) {
- return S_G.new_min_free_gen;
-}
-
-void S_set_minfreegen(IGEN g) {
- S_G.new_min_free_gen = g;
- if (S_G.new_max_nonstatic_generation == S_G.max_nonstatic_generation) {
- S_G.min_free_gen = g;
- }
-}
-
-static IBOOL memqp(ptr x, ptr ls) {
- for (;;) {
- if (ls == Snil) return 0;
- if (Scar(ls) == x) return 1;
- ls = Scdr(ls);
- }
-}
-
-static IBOOL remove_first_nomorep(ptr x, ptr *pls, IBOOL look) {
- ptr ls;
-
- for (;;) {
- ls = *pls;
- if (ls == Snil) break;
- if (Scar(ls) == x) {
- ls = Scdr(ls);
- *pls = ls;
- if (look) return !memqp(x, ls);
- break;
- }
- pls = &Scdr(ls);
- }
-
- /* must return 0 if we don't look for more */
- return 0;
-}
-
-IBOOL Slocked_objectp(ptr x) {
- seginfo *si; IGEN g; IBOOL ans; ptr ls;
-
- if (IMMEDIATE(x) || (si = MaybeSegInfo(ptr_get_segment(x))) == NULL || (g = si->generation) == static_generation) return 1;
-
- tc_mutex_acquire()
-
- ans = 0;
- for (ls = S_G.locked_objects[g]; ls != Snil; ls = Scdr(ls)) {
- if (x == Scar(ls)) {
- ans = 1;
- break;
- }
- }
-
- tc_mutex_release()
-
- return ans;
-}
-
-ptr S_locked_objects(void) {
- IGEN g; ptr ans; ptr ls;
-
- tc_mutex_acquire()
-
- ans = Snil;
- for (g = 0; g <= static_generation; INCRGEN(g)) {
- for (ls = S_G.locked_objects[g]; ls != Snil; ls = Scdr(ls)) {
- ans = Scons(Scar(ls), ans);
- }
- }
-
- tc_mutex_release()
-
- return ans;
-}
-
-void Slock_object(ptr x) {
- seginfo *si; IGEN g;
-
- tc_mutex_acquire()
-
- /* weed out pointers that won't be relocated */
- if (!IMMEDIATE(x) && (si = MaybeSegInfo(ptr_get_segment(x))) != NULL && (g = si->generation) != static_generation) {
- S_pants_down += 1;
- /* add x to locked list. remove from unlocked list */
- S_G.locked_objects[g] = S_cons_in((g == 0 ? space_new : space_impure), g, x, S_G.locked_objects[g]);
- if (S_G.enable_object_counts) {
- if (g != 0) S_G.countof[g][countof_pair] += 1;
- }
- if (si->space & space_locked)
- (void)remove_first_nomorep(x, &S_G.unlocked_objects[g], 0);
- S_pants_down -= 1;
- }
-
- tc_mutex_release()
-}
-
-void Sunlock_object(ptr x) {
- seginfo *si; IGEN g;
-
- tc_mutex_acquire()
-
- if (!IMMEDIATE(x) && (si = MaybeSegInfo(ptr_get_segment(x))) != NULL && (g = si->generation) != static_generation) {
- S_pants_down += 1;
- /* remove first occurrence of x from locked list. if there are no
- others, add x to unlocked list */
- if (remove_first_nomorep(x, &S_G.locked_objects[g], si->space & space_locked)) {
- S_G.unlocked_objects[g] = S_cons_in((g == 0 ? space_new : space_impure), g, x, S_G.unlocked_objects[g]);
- if (S_G.enable_object_counts) {
- if (g != 0) S_G.countof[g][countof_pair] += 1;
- }
- }
- S_pants_down -= 1;
- }
-
- tc_mutex_release()
-}
-
-ptr s_help_unregister_guardian(ptr *pls, ptr tconc, ptr result) {
- ptr rep, ls;
- while ((ls = *pls) != Snil) {
- if (GUARDIANTCONC(ls) == tconc) {
- result = Scons(((rep = GUARDIANREP(ls)) == ftype_guardian_rep ? GUARDIANOBJ(ls) : rep), result);
- *pls = ls = GUARDIANNEXT(ls);
- } else {
- ls = *(pls = &GUARDIANNEXT(ls));
- }
- }
- return result;
-}
-
-ptr S_unregister_guardian(ptr tconc) {
- ptr result, tc; IGEN g;
- tc_mutex_acquire()
- tc = get_thread_context();
- /* in the interest of thread safety, gather entries only in the current thread, ignoring any others */
- result = s_help_unregister_guardian(&GUARDIANENTRIES(tc), tconc, Snil);
- /* plus, of course, any already known to the storage-management system */
- for (g = 0; g <= static_generation; INCRGEN(g)) {
- result = s_help_unregister_guardian(&S_G.guardians[g], tconc, result);
- }
- tc_mutex_release()
- return result;
-}
-
-#ifndef WIN32
-void S_register_child_process(INT child) {
- tc_mutex_acquire()
- S_child_processes[0] = Scons(FIX(child), S_child_processes[0]);
- tc_mutex_release()
-}
-#endif /* WIN32 */
-
-IBOOL S_enable_object_counts(void) {
- return S_G.enable_object_counts;
-}
-
-void S_set_enable_object_counts(IBOOL eoc) {
- S_G.enable_object_counts = eoc;
-}
-
-ptr S_object_counts(void) {
- IGEN grtd, g; ptr ls; iptr i; ptr outer_alist;
-
- tc_mutex_acquire()
-
- outer_alist = Snil;
-
- /* add rtds w/nonozero counts to the alist */
- for (grtd = 0; grtd <= static_generation; INCRGEN(grtd)) {
- for (ls = S_G.rtds_with_counts[grtd]; ls != Snil; ls = Scdr(ls)) {
- ptr rtd = Scar(ls);
- ptr counts = RECORDDESCCOUNTS(rtd);
- IGEN g;
- uptr size = size_record_inst(UNFIX(RECORDDESCSIZE(rtd)));
- ptr inner_alist = Snil;
-
- S_fixup_counts(counts);
- for (g = 0; g <= static_generation; INCRGEN(g)) {
- uptr count = RTDCOUNTSIT(counts, g); IGEN gcurrent = g;
- if (g == S_G.new_max_nonstatic_generation) {
- while (g < S_G.max_nonstatic_generation) {
- g += 1;
- count += RTDCOUNTSIT(counts, g);
- }
- }
- if (count != 0) inner_alist = Scons(Scons((gcurrent == static_generation ? S_G.static_id : FIX(gcurrent)), Scons(Sunsigned(count), Sunsigned(count * size))), inner_alist);
- }
- if (inner_alist != Snil) outer_alist = Scons(Scons(rtd, inner_alist), outer_alist);
- }
- }
-
- /* add primary types w/nonozero counts to the alist */
- for (i = 0 ; i < countof_types; i += 1) {
- ptr inner_alist = Snil;
- for (g = 0; g <= static_generation; INCRGEN(g)) {
- IGEN gcurrent = g;
- uptr count = S_G.countof[g][i];
- uptr bytes = S_G.bytesof[g][i];
-
- if (g == S_G.new_max_nonstatic_generation) {
- while (g < S_G.max_nonstatic_generation) {
- g += 1;
- /* NB: S_G.max_nonstatic_generation + 1 <= static_generation, but coverity complains about overrun */
- /* coverity[overrun-buffer-val] */
- count += S_G.countof[g][i];
- /* coverity[overrun-buffer-val] */
- bytes += S_G.bytesof[g][i];
- }
- }
-
- if (count != 0) {
- if (bytes == 0) bytes = count * S_G.countof_size[i];
- inner_alist = Scons(Scons((gcurrent == static_generation ? S_G.static_id : FIX(gcurrent)), Scons(Sunsigned(count), Sunsigned(bytes))), inner_alist);
- }
- }
- if (inner_alist != Snil) outer_alist = Scons(Scons(Svector_ref(S_G.countof_names, i), inner_alist), outer_alist);
- }
-
- tc_mutex_release()
-
- return outer_alist;
-}
-
-/* Scompact_heap(). Compact into as few O/S chunks as possible and
- * move objects into static generation
- */
-void Scompact_heap(void) {
- ptr tc = get_thread_context();
- S_pants_down += 1;
- S_gc_oce(tc, S_G.max_nonstatic_generation, static_generation, static_generation);
- S_pants_down -= 1;
-}
-
-/* S_check_heap checks for various kinds of heap consistency
- It currently checks for:
- dangling references in space_impure (generation > 0) and space_pure
- extra dirty bits
- missing dirty bits
-
- Some additional things it should check for but doesn't:
- correct dirty bytes, following sweep_dirty conventions
- dangling references in in space_code and space_continuation
- dirty bits set for non-impure segments outside of generation zero
- proper chaining of segments of a space and generation:
- chains contain all and only the appropriate segments
-
- If noisy is nonzero, additional comments may be included in the output
-*/
-
-static void segment_tell(uptr seg) {
- seginfo *si;
- ISPC s, s1;
- static char *spacename[max_space+1] = { alloc_space_names };
-
- printf("segment %#tx", (ptrdiff_t)seg);
- if ((si = MaybeSegInfo(seg)) == NULL) {
- printf(" out of heap bounds\n");
- } else {
- printf(" generation=%d", si->generation);
- s = si->space;
- s1 = si->space & ~(space_old|space_locked);
- if (s1 < 0 || s1 > max_space)
- printf(" space-bogus (%d)", s);
- else {
- printf(" space-%s", spacename[s1]);
- if (s & space_old) printf(" oldspace");
- if (s & space_locked) printf(" locked");
- }
- printf("\n");
- }
- fflush(stdout);
-}
-
-void S_ptr_tell(ptr p) {
- segment_tell(ptr_get_segment(p));
-}
-
-void S_addr_tell(ptr p) {
- segment_tell(addr_get_segment(p));
-}
-
-static void check_heap_dirty_msg(char *msg, ptr *x) {
- INT d; seginfo *si;
-
- si = SegInfo(addr_get_segment(x));
- d = (INT)(((uptr)x >> card_offset_bits) & ((1 << segment_card_offset_bits) - 1));
- printf("%s dirty byte %d found in segment %#tx, card %d at %#tx\n", msg, si->dirty_bytes[d], (ptrdiff_t)(si->number), d, (ptrdiff_t)x);
- printf("from "); segment_tell(addr_get_segment(x));
- printf("to "); segment_tell(addr_get_segment(*x));
-}
-
-void S_check_heap(IBOOL aftergc) {
- uptr seg; INT d; ISPC s; IGEN g; IDIRTYBYTE dirty; IBOOL found_eos; IGEN pg;
- ptr p, *pp1, *pp2, *nl;
- iptr i;
- uptr empty_segments = 0;
- uptr used_segments = 0;
- uptr static_segments = 0;
- uptr nonstatic_segments = 0;
-
- check_dirty();
-
- for (i = PARTIAL_CHUNK_POOLS; i >= -1; i -= 1) {
- chunkinfo *chunk = i == -1 ? S_chunks_full : S_chunks[i];
- while (chunk != NULL) {
- seginfo *si = chunk->unused_segs;
- iptr count = 0;
- while(si) {
- count += 1;
- if (si->space != space_empty) {
- S_checkheap_errors += 1;
- printf("!!! unused segment has unexpected space\n");
- }
- si = si->next;
- }
- if ((chunk->segs - count) != chunk->nused_segs) {
- S_checkheap_errors += 1;
- printf("!!! unexpected used segs count %td with %td total segs and %td segs on the unused list\n",
- (ptrdiff_t)chunk->nused_segs, (ptrdiff_t)chunk->segs, (ptrdiff_t)count);
- }
- used_segments += chunk->nused_segs;
- empty_segments += count;
- chunk = chunk->next;
- }
- }
-
- for (s = 0; s <= max_real_space; s += 1) {
- seginfo *si;
- for (g = 0; g <= S_G.max_nonstatic_generation; INCRGEN(g)) {
- for (si = S_G.occupied_segments[g][s]; si != NULL; si = si->next) {
- nonstatic_segments += 1;
- }
- }
- for (si = S_G.occupied_segments[static_generation][s]; si != NULL; si = si->next) {
- static_segments += 1;
- }
- }
-
- if (used_segments != nonstatic_segments + static_segments) {
- S_checkheap_errors += 1;
- printf("!!! found %#tx used segments and %#tx occupied segments\n",
- (ptrdiff_t)used_segments,
- (ptrdiff_t)(nonstatic_segments + static_segments));
- }
-
- if (S_G.number_of_nonstatic_segments != nonstatic_segments) {
- S_checkheap_errors += 1;
- printf("!!! S_G.number_of_nonstatic_segments %#tx is different from occupied number %#tx\n",
- (ptrdiff_t)S_G.number_of_nonstatic_segments,
- (ptrdiff_t)nonstatic_segments);
- }
-
- if (S_G.number_of_empty_segments != empty_segments) {
- S_checkheap_errors += 1;
- printf("!!! S_G.number_of_empty_segments %#tx is different from unused number %#tx\n",
- (ptrdiff_t)S_G.number_of_empty_segments,
- (ptrdiff_t)empty_segments);
- }
-
- for (i = PARTIAL_CHUNK_POOLS; i >= -1; i -= 1) {
- chunkinfo *chunk = i == -1 ? S_chunks_full : S_chunks[i];
- while (chunk != NULL) {
- uptr nsegs; seginfo *si;
- for (si = &chunk->sis[0], nsegs = chunk->segs; nsegs != 0; nsegs -= 1, si += 1) {
- seginfo *recorded_si; uptr recorded_seg;
- if ((seg = si->number) != (recorded_seg = (chunk->base + chunk->segs - nsegs))) {
- S_checkheap_errors += 1;
- printf("!!! recorded segment number %#tx differs from actual segment number %#tx", (ptrdiff_t)seg, (ptrdiff_t)recorded_seg);
- }
- if ((recorded_si = SegInfo(seg)) != si) {
- S_checkheap_errors += 1;
- printf("!!! recorded segment %#tx seginfo %#tx differs from actual seginfo %#tx", (ptrdiff_t)seg, (ptrdiff_t)recorded_si, (ptrdiff_t)si);
- }
- s = si->space;
- g = si->generation;
-
- if (s == space_new) {
- if (g != 0) {
- S_checkheap_errors += 1;
- printf("!!! unexpected generation %d segment %#tx in space_new\n", g, (ptrdiff_t)seg);
- }
- } else if (s == space_impure || s == space_symbol || s == space_pure || s == space_weakpair /* || s == space_ephemeron */) {
- /* out of date: doesn't handle space_port, space_continuation, space_code, space_pure_typed_object, space_impure_record */
- nl = (ptr *)S_G.next_loc[g][s];
-
- /* check for dangling references */
- pp1 = (ptr *)build_ptr(seg, 0);
- pp2 = (ptr *)build_ptr(seg + 1, 0);
- if (pp1 <= nl && nl < pp2) pp2 = nl;
-
- while (pp1 != pp2) {
- seginfo *psi; ISPC ps;
- p = *pp1;
- if (p == forward_marker) break;
- if (!IMMEDIATE(p) && (psi = MaybeSegInfo(ptr_get_segment(p))) != NULL && ((ps = psi->space) & space_old || ps == space_empty)) {
- S_checkheap_errors += 1;
- printf("!!! dangling reference at %#tx to %#tx\n", (ptrdiff_t)pp1, (ptrdiff_t)p);
- printf("from: "); segment_tell(seg);
- printf("to: "); segment_tell(ptr_get_segment(p));
- }
- pp1 += 1;
- }
-
- /* verify that dirty bits are set appropriately */
- /* out of date: doesn't handle space_impure_record, space_port, and maybe others */
- /* also doesn't check the SYMCODE for symbols */
- if (s == space_impure || s == space_symbol || s == space_weakpair /* || s == space_ephemeron */) {
- found_eos = 0;
- pp2 = pp1 = build_ptr(seg, 0);
- for (d = 0; d < cards_per_segment; d += 1) {
- if (found_eos) {
- if (si->dirty_bytes[d] != 0xff) {
- S_checkheap_errors += 1;
- printf("!!! Dirty byte set past end-of-segment for segment %#tx, card %d\n", (ptrdiff_t)seg, d);
- segment_tell(seg);
- }
- continue;
- }
-
- pp2 += bytes_per_card / sizeof(ptr);
- if (pp1 <= nl && nl < pp2) {
- found_eos = 1;
- pp2 = nl;
- }
-
-#ifdef DEBUG
- printf("pp1 = %#tx, pp2 = %#tx, nl = %#tx\n", (ptrdiff_t)pp1, (ptrdiff_t)pp2, (ptrdiff_t)nl);
- fflush(stdout);
-#endif
-
- dirty = 0xff;
- while (pp1 != pp2) {
- seginfo *psi;
- p = *pp1;
-
- if (p == forward_marker) {
- found_eos = 1;
- break;
- }
- if (!IMMEDIATE(p) && (psi = MaybeSegInfo(ptr_get_segment(p))) != NULL && (pg = psi->generation) < g) {
- if (pg < dirty) dirty = pg;
- if (si->dirty_bytes[d] > pg) {
- S_checkheap_errors += 1;
- check_heap_dirty_msg("!!! INVALID", pp1);
- }
- else if (checkheap_noisy)
- check_heap_dirty_msg("... ", pp1);
- }
- pp1 += 1;
- }
- if (checkheap_noisy && si->dirty_bytes[d] < dirty) {
- /* sweep_dirty won't sweep, and update dirty byte, for
- cards with dirty pointers to segments older than the
- maximum copied generation, so we can get legitimate
- conservative dirty bytes even after gc */
- printf("... Conservative dirty byte %x (%x) %sfor segment %#tx card %d ",
- si->dirty_bytes[d], dirty,
- (aftergc ? "after gc " : ""),
- (ptrdiff_t)seg, d);
- segment_tell(seg);
- }
- }
- }
- }
- if (aftergc && s != space_empty && !(s & space_locked) && (g == 0 || (s != space_impure && s != space_symbol && s != space_port && s != space_weakpair && s != space_ephemeron && s != space_impure_record))) {
- for (d = 0; d < cards_per_segment; d += 1) {
- if (si->dirty_bytes[d] != 0xff) {
- S_checkheap_errors += 1;
- printf("!!! Unnecessary dirty byte %x (%x) after gc for segment %#tx card %d ",
- si->dirty_bytes[d], 0xff, (ptrdiff_t)(si->number), d);
- segment_tell(seg);
- }
- }
- }
- }
- chunk = chunk->next;
- }
- }
-}
-
-static IBOOL dirty_listedp(seginfo *x, IGEN from_g, IGEN to_g) {
- seginfo *si = DirtySegments(from_g, to_g);
- while (si != NULL) {
- if (si == x) return 1;
- si = si->dirty_next;
- }
- return 0;
-}
-
-static void check_dirty_space(ISPC s) {
- IGEN from_g, to_g, min_to_g; INT d; seginfo *si;
-
- for (from_g = 0; from_g <= static_generation; from_g += 1) {
- for (si = S_G.occupied_segments[from_g][s]; si != NULL; si = si->next) {
- if (si->space & space_locked) continue;
- min_to_g = 0xff;
- for (d = 0; d < cards_per_segment; d += 1) {
- to_g = si->dirty_bytes[d];
- if (to_g != 0xff) {
- if (to_g < min_to_g) min_to_g = to_g;
- if (from_g == 0) {
- S_checkheap_errors += 1;
- printf("!!! (check_dirty): space %d, generation %d segment %#tx card %d is marked dirty\n", s, from_g, (ptrdiff_t)(si->number), d);
- }
- }
- }
- if (min_to_g != si->min_dirty_byte) {
- S_checkheap_errors += 1;
- printf("!!! (check_dirty): space %d, generation %d segment %#tx min_dirty_byte is %d while actual min is %d\n", s, from_g, (ptrdiff_t)(si->number), si->min_dirty_byte, min_to_g);
- segment_tell(si->number);
- } else if (min_to_g != 0xff) {
- if (!dirty_listedp(si, from_g, min_to_g)) {
- S_checkheap_errors += 1;
- printf("!!! (check_dirty): space %d, generation %d segment %#tx is marked dirty but not in dirty-segment list\n", s, from_g, (ptrdiff_t)(si->number));
- segment_tell(si->number);
- }
- }
- }
- }
-}
-
-static void check_dirty(void) {
- IGEN from_g, to_g; seginfo *si;
-
- for (from_g = 1; from_g <= static_generation; from_g = from_g == S_G.max_nonstatic_generation ? static_generation : from_g + 1) {
- for (to_g = 0; (from_g == static_generation) ? (to_g <= S_G.max_nonstatic_generation) : (to_g < from_g); to_g += 1) {
- si = DirtySegments(from_g, to_g);
- if (from_g > S_G.max_nonstatic_generation && from_g != static_generation) {
- if (si != NULL) {
- S_checkheap_errors += 1;
- printf("!!! (check_dirty): unexpected nonempty from-generation %d, to-generation %d dirty segment list\n", from_g, to_g);
- }
- } else {
- while (si != NULL) {
- ISPC s = si->space & ~space_locked;
- IGEN g = si->generation;
- IGEN mingval = si->min_dirty_byte;
- if (g != from_g) {
- S_checkheap_errors += 1;
- printf("!!! (check_dirty): generation %d segment %#tx in %d -> %d dirty list\n", g, (ptrdiff_t)(si->number), from_g, to_g);
- }
- if (mingval != to_g) {
- S_checkheap_errors += 1;
- printf("!!! (check_dirty): dirty byte = %d for segment %#tx in %d -> %d dirty list\n", mingval, (ptrdiff_t)(si->number), from_g, to_g);
- }
- if (s != space_new && s != space_impure && s != space_symbol && s != space_port && s != space_impure_record && s != space_weakpair && s != space_ephemeron) {
- S_checkheap_errors += 1;
- printf("!!! (check_dirty): unexpected space %d for dirty segment %#tx\n", s, (ptrdiff_t)(si->number));
- }
- si = si->dirty_next;
- }
- }
- }
- }
-
- check_dirty_space(space_impure);
- check_dirty_space(space_symbol);
- check_dirty_space(space_port);
- check_dirty_space(space_impure_record);
- check_dirty_space(space_weakpair);
- check_dirty_space(space_ephemeron);
-
- fflush(stdout);
-}
-
-void S_fixup_counts(ptr counts) {
- IGEN g; U64 timestamp;
-
- timestamp = RTDCOUNTSTIMESTAMP(counts);
- for (g = 0; g <= static_generation; INCRGEN(g)) {
- if (timestamp >= S_G.gctimestamp[g]) break;
- RTDCOUNTSIT(counts, g) = 0;
- }
- RTDCOUNTSTIMESTAMP(counts) = S_G.gctimestamp[0];
-}
-
-void S_do_gc(IGEN max_cg, IGEN min_tg, IGEN max_tg) {
- ptr tc = get_thread_context();
- ptr code;
-
- code = CP(tc);
- if (Sprocedurep(code)) code = CLOSCODE(code);
- Slock_object(code);
-
- /* Scheme side grabs mutex before calling S_do_gc */
- S_pants_down += 1;
-
- if (S_G.new_max_nonstatic_generation > S_G.max_nonstatic_generation) {
- S_G.min_free_gen = S_G.new_min_free_gen;
- S_G.max_nonstatic_generation = S_G.new_max_nonstatic_generation;
- }
-
- if (max_tg == max_cg && max_cg == S_G.new_max_nonstatic_generation && max_cg < S_G.max_nonstatic_generation) {
- IGEN new_g, old_g, from_g, to_g; ISPC s; seginfo *si, *nextsi, *tail;
- /* reducing max_nonstatic_generation */
- new_g = S_G.new_max_nonstatic_generation;
- old_g = S_G.max_nonstatic_generation;
- /* first, collect everything to old_g, ignoring min_tg */
- S_gc(tc, old_g, old_g, old_g);
- /* now transfer old_g info to new_g, and clear old_g info */
- S_G.bytes_of_generation[new_g] = S_G.bytes_of_generation[old_g]; S_G.bytes_of_generation[old_g] = 0;
- for (s = 0; s <= max_real_space; s += 1) {
- S_G.first_loc[new_g][s] = S_G.first_loc[old_g][s]; S_G.first_loc[old_g][s] = FIX(0);
- S_G.base_loc[new_g][s] = S_G.base_loc[old_g][s]; S_G.base_loc[old_g][s] = FIX(0);
- S_G.next_loc[new_g][s] = S_G.next_loc[old_g][s]; S_G.next_loc[old_g][s] = FIX(0);
- S_G.bytes_left[new_g][s] = S_G.bytes_left[old_g][s]; S_G.bytes_left[old_g][s] = 0;
- S_G.bytes_of_space[new_g][s] = S_G.bytes_of_space[old_g][s]; S_G.bytes_of_space[old_g][s] = 0;
- S_G.occupied_segments[new_g][s] = S_G.occupied_segments[old_g][s]; S_G.occupied_segments[old_g][s] = NULL;
- for (si = S_G.occupied_segments[new_g][s]; si != NULL; si = si->next) {
- si->generation = new_g;
- }
- }
- S_G.guardians[new_g] = S_G.guardians[old_g]; S_G.guardians[old_g] = Snil;
- S_G.locked_objects[new_g] = S_G.locked_objects[old_g]; S_G.locked_objects[old_g] = Snil;
- S_G.unlocked_objects[new_g] = S_G.unlocked_objects[old_g]; S_G.unlocked_objects[old_g] = Snil;
- S_G.buckets_of_generation[new_g] = S_G.buckets_of_generation[old_g]; S_G.buckets_of_generation[old_g] = NULL;
- if (S_G.enable_object_counts) {
- INT i; ptr ls;
- for (i = 0; i < countof_types; i += 1) {
- S_G.countof[new_g][i] = S_G.countof[old_g][i]; S_G.countof[old_g][i] = 0;
- S_G.bytesof[new_g][i] = S_G.bytesof[old_g][i]; S_G.bytesof[old_g][i] = 0;
- }
- S_G.rtds_with_counts[new_g] = S_G.rtds_with_counts[old_g]; S_G.rtds_with_counts[old_g] = Snil;
- for (ls = S_G.rtds_with_counts[new_g]; ls != Snil; ls = Scdr(ls)) {
- ptr counts = RECORDDESCCOUNTS(Scar(ls));
- RTDCOUNTSIT(counts, new_g) = RTDCOUNTSIT(counts, old_g); RTDCOUNTSIT(counts, old_g) = 0;
- }
- for (ls = S_G.rtds_with_counts[static_generation]; ls != Snil; ls = Scdr(ls)) {
- ptr counts = RECORDDESCCOUNTS(Scar(ls));
- RTDCOUNTSIT(counts, new_g) = RTDCOUNTSIT(counts, old_g); RTDCOUNTSIT(counts, old_g) = 0;
- }
- }
-#ifndef WIN32
- S_child_processes[new_g] = S_child_processes[old_g];
-#endif
-
- /* change old_g dirty bytes in static generation to new_g; splice list of old_g
- seginfos onto front of new_g seginfos */
- for (from_g = 1; from_g <= static_generation; INCRGEN(from_g)) {
- for (to_g = 0; (from_g == static_generation) ? (to_g <= S_G.max_nonstatic_generation) : (to_g < from_g); to_g += 1) {
- if ((si = DirtySegments(from_g, to_g)) != NULL) {
- if (from_g == old_g) {
- DirtySegments(from_g, to_g) = NULL;
- DirtySegments(new_g, to_g) = si;
- si->dirty_prev = &DirtySegments(new_g, to_g);
- } else if (from_g == static_generation) {
- if (to_g == old_g) {
- DirtySegments(from_g, to_g) = NULL;
- tail = DirtySegments(from_g, new_g);
- DirtySegments(from_g, new_g) = si;
- si->dirty_prev = &DirtySegments(from_g, new_g);
- for (;;) {
- INT d;
- si->min_dirty_byte = new_g;
- for (d = 0; d < cards_per_segment; d += 1) {
- if (si->dirty_bytes[d] == old_g) si->dirty_bytes[d] = new_g;
- }
- nextsi = si->dirty_next;
- if (nextsi == NULL) break;
- si = nextsi;
- }
- if (tail != NULL) tail->dirty_prev = &si->dirty_next;
- si->dirty_next = tail;
- } else {
- do {
- INT d;
- for (d = 0; d < cards_per_segment; d += 1) {
- if (si->dirty_bytes[d] == old_g) si->dirty_bytes[d] = new_g;
- }
- si = si->dirty_next;
- } while (si != NULL);
- }
- } else {
- S_error_abort("S_do_gc(gc): unexpected nonempty dirty segment list");
- }
- }
- }
- }
-
- /* tell profile_release_counters to scan only through new_g */
- if (S_G.prcgeneration == old_g) S_G.prcgeneration = new_g;
-
- /* finally reset max_nonstatic_generation */
- S_G.min_free_gen = S_G.new_min_free_gen;
- S_G.max_nonstatic_generation = new_g;
- } else {
- S_gc(tc, max_cg, min_tg, max_tg);
- }
-
- /* eagerly give collecting thread, the only one guaranteed to be
- active, a fresh allocation area. the other threads have to trap
- to get_more_room if and when they awake and try to allocate */
- S_reset_allocation_pointer(tc);
-
- S_pants_down -= 1;
-
- Sunlock_object(code);
-}
-
-
-void S_gc(ptr tc, IGEN max_cg, IGEN min_tg, IGEN max_tg) {
- if (max_cg == 0 && min_tg == 1 && max_tg == 1 && S_G.locked_objects[0] == Snil)
- S_gc_011(tc);
- else if (max_tg == static_generation || S_G.enable_object_counts)
- S_gc_oce(tc, max_cg, min_tg, max_tg);
- else
- S_gc_ocd(tc, max_cg, min_tg, max_tg);
-}
diff --git a/ta6ob/c/gcwrapper.o b/ta6ob/c/gcwrapper.o
deleted file mode 100644
index cdc4f71..0000000
Binary files a/ta6ob/c/gcwrapper.o and /dev/null differ
diff --git a/ta6ob/c/globals.h b/ta6ob/c/globals.h
deleted file mode 100644
index f08c2b9..0000000
--- a/ta6ob/c/globals.h
+++ /dev/null
@@ -1,156 +0,0 @@
-/* globals.h
- * Copyright 1984-2017 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.
- */
-
-/* globals that do NOT need to be preserved in a saved heap.
- * they must be initialized each time the system is brought up. */
-
-/* gc.c */
-EXTERN IBOOL S_checkheap;
-EXTERN uptr S_checkheap_errors;
-#ifndef WIN32
-EXTERN ptr S_child_processes[static_generation+1];
-#endif /* WIN32 */
-
-/* scheme.c */
-EXTERN IBOOL S_boot_time;
-EXTERN IBOOL S_errors_to_console;
-EXTERN ptr S_threads;
-EXTERN uptr S_nthreads;
-EXTERN uptr S_pagesize;
-EXTERN void (*S_abnormal_exit_proc)();
-EXTERN char *Sschemeheapdirs;
-EXTERN char *Sdefaultheapdirs;
-#ifdef PTHREADS
-EXTERN s_thread_key_t S_tc_key;
-EXTERN scheme_mutex_t S_tc_mutex;
-EXTERN s_thread_cond_t S_collect_cond;
-EXTERN INT S_tc_mutex_depth;
-#endif
-
-/* segment.c */
-#ifdef segment_t2_bits
-#ifdef segment_t3_bits
-EXTERN t2table *S_segment_info[1<
-#include
-
-#ifdef FLUSHCACHE
-oops, no S_flushcache_max_gap or S_doflush
-#endif /* FLUSHCACHE */
-
-void S_machine_init(void) {}
diff --git a/ta6ob/c/i3le.o b/ta6ob/c/i3le.o
deleted file mode 100644
index 3d62b44..0000000
Binary files a/ta6ob/c/i3le.o and /dev/null differ
diff --git a/ta6ob/c/intern.c b/ta6ob/c/intern.c
deleted file mode 100644
index 3758a3b..0000000
--- a/ta6ob/c/intern.c
+++ /dev/null
@@ -1,389 +0,0 @@
-/* intern.c
- * Copyright 1984-2017 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.
- */
-
-#include "system.h"
-
-/* locally defined functions */
-static void oblist_insert(ptr sym, iptr idx, IGEN g);
-static iptr hash(const unsigned char *s, iptr n);
-static iptr hash_sc(const string_char *s, iptr n);
-static iptr hash_uname(const string_char *s, iptr n);
-static ptr mkstring(const string_char *s, iptr n);
-
-/* list of some primes to use for oblist sizes */
-#if (ptr_bits == 32)
-static iptr oblist_lengths[] = {
- 1031,
- 2053,
- 4099,
- 8209,
- 16411,
- 32771,
- 65537,
- 131101,
- 262147,
- 524309,
- 1048583,
- 2097169,
- 4194319,
- 8388617,
- 16777259,
- 33554467,
- 67108879,
- 134217757,
- 268435459,
- 536870923,
- 1073741827,
- 0};
-#endif
-#if (ptr_bits == 64)
-static iptr oblist_lengths[] = {
- 1031,
- 2053,
- 4099,
- 8209,
- 16411,
- 32771,
- 65537,
- 131101,
- 262147,
- 524309,
- 1048583,
- 2097169,
- 4194319,
- 8388617,
- 16777259,
- 33554467,
- 67108879,
- 134217757,
- 268435459,
- 536870923,
- 1073741827,
- 2147483659,
- 4294967311,
- 8589934609,
- 17179869209,
- 34359738421,
- 68719476767,
- 137438953481,
- 274877906951,
- 549755813911,
- 1099511627791,
- 2199023255579,
- 4398046511119,
- 8796093022237,
- 17592186044423,
- 35184372088891,
- 70368744177679,
- 140737488355333,
- 281474976710677,
- 562949953421381,
- 1125899906842679,
- 2251799813685269,
- 4503599627370517,
- 9007199254740997,
- 18014398509482143,
- 36028797018963971,
- 72057594037928017,
- 144115188075855881,
- 288230376151711813,
- 576460752303423619,
- 1152921504606847009,
- 2305843009213693967,
- 4611686018427388039,
- 0};
-#endif
-
-void S_intern_init(void) {
- IGEN g;
-
- if (!S_boot_time) return;
-
- S_G.oblist_length_pointer = &oblist_lengths[3];
- S_G.oblist_length = *S_G.oblist_length_pointer;
- S_G.oblist_count = 0;
- S_G.oblist = S_getmem(S_G.oblist_length * sizeof(bucket *), 1);
- for (g = 0; g < static_generation; g += 1) S_G.buckets_of_generation[g] = NULL;
-}
-
-static void oblist_insert(ptr sym, iptr idx, IGEN g) {
- bucket *b, *oldb, **pb;
-
- find_room(g == 0 ? space_new : space_data, g, typemod, sizeof(bucket), b);
- b->sym = sym;
- if (g == 0) {
- b->next = S_G.oblist[idx];
- S_G.oblist[idx] = b;
- } else {
- for (pb = &S_G.oblist[idx]; (oldb = *pb) != NULL && SegmentGeneration(addr_get_segment(oldb)) < g; pb = &oldb->next);
- b->next = oldb;
- *pb = b;
- }
-
- if (g != static_generation) {
- bucket_list *bl;
- find_room(g == 0 ? space_new : space_data, g, typemod, sizeof(bucket_list), bl);
- bl->car = b;
- bl->cdr = S_G.buckets_of_generation[g];
- S_G.buckets_of_generation[g] = bl;
- }
-
- S_G.oblist_count += 1;
-}
-
-void S_resize_oblist(void) {
- bucket **new_oblist, *b, *oldb, **pb, *bnext;
- iptr *new_oblist_length_pointer, new_oblist_length, i, idx;
- ptr sym;
- IGEN g;
-
- new_oblist_length_pointer = S_G.oblist_length_pointer;
-
- if (S_G.oblist_count < S_G.oblist_length) {
- while (new_oblist_length_pointer != &oblist_lengths[0] && *(new_oblist_length_pointer - 1) >= S_G.oblist_count) {
- new_oblist_length_pointer -= 1;
- }
- } else if (S_G.oblist_count > S_G.oblist_length) {
- while (*(new_oblist_length_pointer + 1) != 0 && *(new_oblist_length_pointer + 1) <= S_G.oblist_count) {
- new_oblist_length_pointer += 1;
- }
- }
-
- if (new_oblist_length_pointer == S_G.oblist_length_pointer) return;
-
- new_oblist_length = *new_oblist_length_pointer;
- new_oblist = S_getmem(new_oblist_length * sizeof(bucket *), 1);
-
- for (i = 0; i < S_G.oblist_length; i += 1) {
- for (b = S_G.oblist[i]; b != NULL; b = bnext) {
- bnext = b->next;
- sym = b->sym;
- idx = UNFIX(SYMHASH(sym)) % new_oblist_length;
- g = GENERATION(sym);
-
- for (pb = &new_oblist[idx]; (oldb = *pb) != NULL && SegmentGeneration(addr_get_segment(oldb)) < g; pb = &oldb->next);
- b->next = oldb;
- *pb = b;
- }
- }
-
- S_freemem(S_G.oblist, S_G.oblist_length * sizeof(bucket *));
- S_G.bytesof[static_generation][countof_oblist] += (new_oblist_length - S_G.oblist_length) * sizeof(bucket *);
-
- S_G.oblist_length_pointer = new_oblist_length_pointer;
- S_G.oblist_length = new_oblist_length;
- S_G.oblist = new_oblist;
-}
-
-/* hash function: multiplier weights each character, h = n factors in the length */
-#define multiplier 3
-
-static iptr hash(const unsigned char *s, iptr n) {
- iptr h = n + 401887359;
- while (n--) h = h * multiplier + *s++;
- return h & most_positive_fixnum;
-}
-
-static iptr hash_sc(const string_char *s, iptr n) {
- iptr h = n + 401887359;
- while (n--) h = h * multiplier + Schar_value(*s++);
- return h & most_positive_fixnum;
-}
-
-static iptr hash_uname(const string_char *s, iptr n) {
- /* attempting to get dissimilar hash codes for gensyms created in the same session */
- iptr i = n, h = 0; iptr pos = 1; int d, c;
-
- while (i-- > 0) {
- if ((c = Schar_value(s[i])) == '-') {
- if (pos <= 10) break;
- return (h + 523658599) & most_positive_fixnum;
- }
- d = c - '0';
- if (d < 0 || d > 9) break;
- h += d * pos;
- pos *= 10;
- }
-
- return hash_sc(s, n);
-}
-
-static ptr mkstring(const string_char *s, iptr n) {
- iptr i;
- ptr str = S_string(NULL, n);
- for (i = 0; i != n; i += 1) STRIT(str, i) = s[i];
- return str;
-}
-
-/* handles single-byte characters, implicit length */
-ptr S_intern(const unsigned char *s) {
- iptr n = strlen((const char *)s);
- iptr hc = hash(s, n);
- iptr idx = hc % S_G.oblist_length;
- ptr sym;
- bucket *b;
-
- tc_mutex_acquire()
-
- b = S_G.oblist[idx];
- while (b != NULL) {
- sym = b->sym;
- if (!GENSYMP(sym)) {
- ptr str = SYMNAME(sym);
- if (Sstring_length(str) == n) {
- iptr i;
- for (i = 0; ; i += 1) {
- if (i == n) {
- tc_mutex_release()
- return sym;
- }
- if (Sstring_ref(str, i) != s[i]) break;
- }
- }
- }
- b = b->next;
- }
-
- sym = S_symbol(S_string((const char *)s, n));
- INITSYMHASH(sym) = FIX(hc);
- oblist_insert(sym, idx, 0);
-
- tc_mutex_release()
- return sym;
-}
-
-/* handles string_chars, explicit length */
-ptr S_intern_sc(const string_char *name, iptr n, ptr name_str) {
- iptr hc = hash_sc(name, n);
- iptr idx = hc % S_G.oblist_length;
- ptr sym;
- bucket *b;
-
- tc_mutex_acquire()
-
- b = S_G.oblist[idx];
- while (b != NULL) {
- sym = b->sym;
- if (!GENSYMP(sym)) {
- ptr str = SYMNAME(sym);
- if (Sstring_length(str) == n) {
- iptr i;
- for (i = 0; ; i += 1) {
- if (i == n) {
- tc_mutex_release()
- return sym;
- }
- if (STRIT(str, i) != name[i]) break;
- }
- }
- }
- b = b->next;
- }
-
- /* if (name_str == Sfalse) */ name_str = mkstring(name, n);
- sym = S_symbol(name_str);
- INITSYMHASH(sym) = FIX(hc);
- oblist_insert(sym, idx, 0);
-
- tc_mutex_release()
- return sym;
-}
-
-ptr S_intern3(const string_char *pname, iptr plen, const string_char *uname, iptr ulen, ptr pname_str, ptr uname_str) {
- iptr hc = hash_uname(uname, ulen);
- iptr idx = hc % S_G.oblist_length;
- ptr sym;
- bucket *b;
-
- tc_mutex_acquire()
-
- b = S_G.oblist[idx];
- while (b != NULL) {
- sym = b->sym;
- if (GENSYMP(sym)) {
- ptr str = Scar(SYMNAME(sym));
- if (Sstring_length(str) == ulen) {
- iptr i;
- for (i = 0; ; i += 1) {
- if (i == ulen) {
- tc_mutex_release()
- return sym;
- }
- if (STRIT(str, i) != uname[i]) break;
- }
- }
- }
- b = b->next;
- }
-
- if (pname_str == Sfalse) pname_str = mkstring(pname, plen);
- if (uname_str == Sfalse) uname_str = mkstring(uname, ulen);
- sym = S_symbol(Scons(uname_str, pname_str));
- INITSYMHASH(sym) = FIX(hc);
- oblist_insert(sym, idx, 0);
-
- tc_mutex_release()
- return sym;
-}
-
-void S_intern_gensym(ptr sym) {
- ptr uname_str = Scar(SYMNAME(sym));
- const string_char *uname = &STRIT(uname_str, 0);
- iptr ulen = Sstring_length(uname_str);
- iptr hc = hash_uname(uname, ulen);
- iptr idx = hc % S_G.oblist_length;
- bucket *b;
-
- tc_mutex_acquire()
-
- b = S_G.oblist[idx];
- while (b != NULL) {
- ptr x = b->sym;
- if (GENSYMP(x)) {
- ptr str = Scar(SYMNAME(x));
- if (Sstring_length(str) == ulen) {
- iptr i;
- for (i = 0; ; i += 1) {
- if (i == ulen) {
- tc_mutex_release()
- S_error1("intern-gensym", "unique name ~s already interned", uname_str);
- }
- if (Sstring_ref(str, i) != uname[i]) break;
- }
- }
- }
- b = b->next;
- }
-
- INITSYMHASH(sym) = FIX(hc);
- oblist_insert(sym, idx, GENERATION(sym));
-
- tc_mutex_release()
-}
-
-/* retrofit existing symbols once nonprocedure_code is available */
-void S_retrofit_nonprocedure_code(void) {
- ptr npc, sym, val; bucket_list *bl;
-
- npc = S_G.nonprocedure_code;
-
- /* assuming this happens early, before collector has been called, so need look only for generation 0 symbols */
- for (bl = S_G.buckets_of_generation[0]; bl != NULL; bl = bl->cdr) {
- sym = bl->car->sym;
- val = SYMVAL(sym);
- SETSYMCODE(sym, Sprocedurep(val) ? CLOSCODE(val) : npc);
- }
-}
diff --git a/ta6ob/c/intern.o b/ta6ob/c/intern.o
deleted file mode 100644
index 627da63..0000000
Binary files a/ta6ob/c/intern.o and /dev/null differ
diff --git a/ta6ob/c/io.c b/ta6ob/c/io.c
deleted file mode 100644
index 9c2eea6..0000000
--- a/ta6ob/c/io.c
+++ /dev/null
@@ -1,277 +0,0 @@
-/* io.c
- * Copyright 1984-2017 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.
- */
-
-#include "system.h"
-#include
-#include
-#include
-#ifdef WIN32
-#include
-#include
-#pragma comment(lib, "shell32.lib")
-#else /* WIN32 */
-#include
-#include
-#include
-#endif /* WIN32 */
-
-/* locally defined functions */
-#ifdef WIN32
-static ptr s_wstring_to_bytevector(const wchar_t *s);
-#else
-static ptr s_string_to_bytevector(const char *s);
-#endif
-
-/* raises an exception if insufficient space cannot be malloc'd.
- otherwise returns a freshly allocated version of inpath with ~ (home directory)
- prefix expanded, if possible */
-char *S_malloc_pathname(const char *inpath) {
- char *outpath; const char *ip;
-
-#ifdef WIN32
- if (*inpath == '~' && (*(ip = inpath + 1) == 0 || DIRMARKERP(*ip))) {
- wchar_t* homew;
- if (SUCCEEDED(SHGetKnownFolderPath(&FOLDERID_Profile, 0, NULL, &homew))) {
- char *home = Swide_to_utf8(homew);
- CoTaskMemFree(homew);
- if (NULL != home) {
- size_t n1, n2;
- n1 = strlen(home);
- n2 = strlen(ip) + 1;
- if ((outpath = malloc(n1 + n2)) == NULL) {
- free(home);
- S_error("expand_pathname", "malloc failed");
- }
- memcpy(outpath, home, n1);
- memcpy(outpath + n1, ip, n2);
- free(home);
- return outpath;
- }
- }
- }
-#else /* WIN32 */
- if (*inpath == '~') {
- const char *dir; size_t n1, n2; struct passwd *pwent;
- if (*(ip = inpath + 1) == 0 || DIRMARKERP(*ip)) {
- if ((dir = getenv("HOME")) == NULL)
- if ((pwent = getpwuid(getuid())) != NULL)
- dir = pwent->pw_dir;
- } else {
- char *userbuf; const char *user_start = ip;
- do { ip += 1; } while (*ip != 0 && !DIRMARKERP(*ip));
- if ((userbuf = malloc(ip - user_start + 1)) == NULL) S_error("expand_pathname", "malloc failed");
- memcpy(userbuf, user_start, ip - user_start);
- userbuf[ip - user_start] = 0;
- dir = (pwent = getpwnam(userbuf)) != NULL ? pwent->pw_dir : NULL;
- free(userbuf);
- }
- if (dir != NULL) {
- n1 = strlen(dir);
- n2 = strlen(ip) + 1;
- if ((outpath = malloc(n1 + n2)) == NULL) S_error("expand_pathname", "malloc failed");
- memcpy(outpath, dir, n1);
- memcpy(outpath + n1, ip, n2);
- return outpath;
- }
- }
-#endif /* WIN32 */
-
- /* if no ~ or tilde dir can't be found, copy inpath */
- {
- size_t n = strlen(inpath) + 1;
- if ((outpath = (char *)malloc(n)) == NULL) S_error("expand_pathname", "malloc failed");
- memcpy(outpath, inpath, n);
- return outpath;
- }
-}
-
-#ifdef WIN32
-wchar_t *S_malloc_wide_pathname(const char *inpath) {
- char *path = S_malloc_pathname(inpath);
- wchar_t *wpath = Sutf8_to_wide(path);
- free(path);
- return wpath;
-}
-#endif
-
-IBOOL S_fixedpathp(const char *inpath) {
- char c; IBOOL res; char *path;
-
- path = S_malloc_pathname(inpath);
- res = (c = *path) == 0
- || DIRMARKERP(c)
-#ifdef WIN32
- || ((*(path + 1) == ':') && (c >= 'a' && c <= 'z' || c >= 'A' && c <= 'Z'))
-#endif
- || ((c == '.')
- && ((c = *(path + 1)) == 0
- || DIRMARKERP(c)
- || (c == '.' && ((c = *(path + 2)) == 0 || DIRMARKERP(c)))));
- free(path);
- return res;
-}
-
-IBOOL S_file_existsp(const char *inpath, IBOOL followp) {
-#ifdef WIN32
- wchar_t *wpath; IBOOL res;
- WIN32_FILE_ATTRIBUTE_DATA filedata;
-
- if ((wpath = S_malloc_wide_pathname(inpath)) == NULL) {
- return 0;
- } else {
- res = GetFileAttributesExW(wpath, GetFileExInfoStandard, &filedata);
- free(wpath);
- return res;
- }
-#else /* WIN32 */
- struct STATBUF statbuf; char *path; IBOOL res;
-
- path = S_malloc_pathname(inpath);
- res = (followp ? STAT(path, &statbuf) : LSTAT(path, &statbuf)) == 0;
- free(path);
- return res;
-#endif /* WIN32 */
-}
-
-IBOOL S_file_regularp(const char *inpath, IBOOL followp) {
-#ifdef WIN32
- wchar_t *wpath; IBOOL res;
- WIN32_FILE_ATTRIBUTE_DATA filedata;
-
- if ((wpath = S_malloc_wide_pathname(inpath)) == NULL) {
- return 0;
- } else {
- res = GetFileAttributesExW(wpath, GetFileExInfoStandard, &filedata)
- && (filedata.dwFileAttributes & (FILE_ATTRIBUTE_DEVICE | FILE_ATTRIBUTE_DIRECTORY | FILE_ATTRIBUTE_REPARSE_POINT)) == 0;
- free(wpath);
- return res;
- }
-#else /* WIN32 */
- struct STATBUF statbuf; char *path; IBOOL res;
-
- path = S_malloc_pathname(inpath);
- res = (followp ? STAT(path, &statbuf) : LSTAT(path, &statbuf)) == 0
- && (statbuf.st_mode & S_IFMT) == S_IFREG;
- free(path);
- return res;
-#endif /* WIN32 */
-}
-
-IBOOL S_file_directoryp(const char *inpath, IBOOL followp) {
-#ifdef WIN32
- wchar_t *wpath; IBOOL res;
- WIN32_FILE_ATTRIBUTE_DATA filedata;
-
- if ((wpath = S_malloc_wide_pathname(inpath)) == NULL) {
- return 0;
- } else {
- res = GetFileAttributesExW(wpath, GetFileExInfoStandard, &filedata)
- && filedata.dwFileAttributes & FILE_ATTRIBUTE_DIRECTORY;
- free(wpath);
- return res;
- }
-#else /* WIN32 */
- struct STATBUF statbuf; char *path; IBOOL res;
-
- path = S_malloc_pathname(inpath);
- res = (followp ? STAT(path, &statbuf) : LSTAT(path, &statbuf)) == 0
- && (statbuf.st_mode & S_IFMT) == S_IFDIR;
- free(path);
- return res;
-#endif /* WIN32 */
-}
-
-IBOOL S_file_symbolic_linkp(const char *inpath) {
-#ifdef WIN32
- wchar_t *wpath; IBOOL res;
- WIN32_FILE_ATTRIBUTE_DATA filedata;
-
- if ((wpath = S_malloc_wide_pathname(inpath)) == NULL) {
- return 0;
- } else {
- res = GetFileAttributesExW(wpath, GetFileExInfoStandard, &filedata)
- && filedata.dwFileAttributes & FILE_ATTRIBUTE_REPARSE_POINT;
- free(wpath);
- return res;
- }
-#else /* WIN32 */
- struct STATBUF statbuf; char *path; IBOOL res;
-
- path = S_malloc_pathname(inpath);
- res = LSTAT(path, &statbuf) == 0 && (statbuf.st_mode & S_IFMT) == S_IFLNK;
- free(path);
- return res;
-#endif /* WIN32 */
-}
-
-#ifdef WIN32
-static ptr s_wstring_to_bytevector(const wchar_t *s) {
- iptr n; ptr bv;
- if ((n = wcslen(s)) == 0) return S_G.null_bytevector;
- n *= sizeof(wchar_t);
- bv = S_bytevector(n);
- memcpy(&BVIT(bv,0), s, n);
- return bv;
-}
-
-ptr S_find_files(const char *wildpath) {
- wchar_t *wwildpath;
- intptr_t handle;
- struct _wfinddata_t fileinfo;
-
- if ((wwildpath = S_malloc_wide_pathname(wildpath)) == NULL)
- return S_LastErrorString();
-
- if ((handle = _wfindfirst(wwildpath, &fileinfo)) == (intptr_t)-1) {
- free(wwildpath);
- return S_strerror(errno);
- } else {
- ptr ls = Snil;
- do {
- ls = Scons(s_wstring_to_bytevector(fileinfo.name), ls);
- } while (_wfindnext(handle, &fileinfo) == 0);
- _findclose(handle);
- free(wwildpath);
- return ls;
- }
-}
-#else /* WIN32 */
-static ptr s_string_to_bytevector(const char *s) {
- iptr n; ptr bv;
- if ((n = strlen(s)) == 0) return S_G.null_bytevector;
- bv = S_bytevector(n);
- memcpy(&BVIT(bv,0), s, n);
- return bv;
-}
-
-ptr S_directory_list(const char *inpath) {
- char *path; DIR *dirp;
-
- path = S_malloc_pathname(inpath);
- if ((dirp = opendir(path)) == (DIR *)0) {
- free(path);
- return S_strerror(errno);
- } else {
- struct dirent *dep; ptr ls = Snil;
-
- while ((dep = readdir(dirp)) != (struct dirent *)0)
- ls = Scons(s_string_to_bytevector(dep->d_name), ls);
- closedir(dirp);
- free(path);
- return ls;
- }
-}
-#endif /* WIN32 */
diff --git a/ta6ob/c/io.o b/ta6ob/c/io.o
deleted file mode 100644
index bcfd662..0000000
Binary files a/ta6ob/c/io.o and /dev/null differ
diff --git a/ta6ob/c/itest.c b/ta6ob/c/itest.c
deleted file mode 100644
index 21c1847..0000000
--- a/ta6ob/c/itest.c
+++ /dev/null
@@ -1,247 +0,0 @@
-/* itest.c
- * Copyright 1984-2017 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 r_EOF 0
-#define r_LPAREN 1
-#define r_RPAREN 2
-#define r_CONST 3
-
-static INT digit_value(ICHAR c, INT r) {
- switch (r) {
- case 2:
- if ('0' <= c && c <= '1') return c - '0';
- break;
- case 8:
- if ('0' <= c && c <= '8') return c - '0';
- break;
- case 10:
- if ('0' <= c && c <= '9') return c - '0';
- break;
- case 16:
- if ('0' <= c && c <= '9') return c - '0';
- if ('a' <= c && c <= 'f') return c - 'a';
- if ('A' <= c && c <= 'F') return c - 'A';
- default:
- break;
- }
- return -1;
-}
-
-static INT read_int(ptr *v, ptr n, INT r, IBOOL sign) {
- INT i, c;
-
- for (;;) {
- if ((i = digit_value((c = getchar()), r)) == -1) {
- ungetc(c, stdin);
- break;
- }
- n = S_add(S_mul(n, FIX(r)), FIX(i));
- }
- *v = sign ? S_sub(FIX(0), n) : n;
- return r_CONST;
-}
-
-static INT read_token(ptr *v) {
- ICHAR c = getchar();
- switch (c) {
- case SEOF: return r_EOF;
- case '\n':
- case ' ': return read_token(v);
- case ';':
- for (;;) {
- switch (getchar()) {
- case SEOF:
- return r_EOF;
- case '\n':
- return read_token(v);
- default:
- break;
- }
- }
- case '(': return r_LPAREN;
- case ')': return r_RPAREN;
- case '#': {
- ICHAR c = getchar();
- INT r = 10;
- switch (c) {
- case 'x':
- r = 16;
- case 'o':
- if (r == 0) r = 8;
- case 'b':
- if (r == 10) r = 2;
- case 'd': {
- INT i;
- IBOOL sign = 0;
- c = getchar();
- if (c == '+')
- c = getchar();
- else if (c == '-') {
- sign = 1;
- c = getchar();
- }
-
- if ((i = digit_value(c, r)) != -1)
- return read_int(v, FIX(i), r, sign);
- }
- default:
- printf("malformed hash prefix ignored\n");
- return read_token(v);
- }
- }
- case '+':
- case '-': {
- INT i, c2;
- if ((i = digit_value((c2 = getchar()), 10)) == -1) {
- ungetc(c2, stdin);
- } else {
- return read_int(v, FIX(i), 10, c == '-');
- }
- }
- case '*':
- case '/':
- case 'q':
- case 'r':
- case 'g':
- case '=':
- case '<':
- case 'f':
- case 'c':
- case 'd':
- *v = Schar(c);
- return r_CONST;
- default: {
- INT i;
- if ((i = digit_value(c, 10)) != -1)
- return read_int(v, FIX(i), 10, 0);
- }
- break;
- }
- printf("invalid character %d ignored\n", c);
- return read_token(v);
-}
-
-static ptr readx(INT t, ptr v);
-
-static ptr read_list(void) {
- INT t; ptr v, x;
-
- t = read_token(&v);
- if (t == r_RPAREN) return Snil;
- x = readx(t, v);
- return Scons(x, read_list());
-}
-
-static ptr readx(INT t, ptr v) {
-
- switch (t) {
- case r_EOF:
- printf("unexpected EOF\n");
- exit(1);
- case r_LPAREN: return read_list();
- case r_RPAREN:
- printf("unexpected right paren ignored\n");
- t = read_token(&v);
- return readx(t, v);
- case r_CONST: return v;
- default:
- printf("invalid token %d\n", t);
- exit(1);
- }
-}
-
-static ptr read_top(void) {
- INT t; ptr v;
-
- t = read_token(&v);
- switch (t) {
- case r_EOF: return Seof_object;
- case r_RPAREN: return read_top();
- default: return readx(t, v);
- }
-}
-
-static ptr eval(ptr x);
-
-#define First(x) eval(Scar(Scdr(x)))
-#define Second(x) eval(Scar(Scdr(Scdr(x))))
-
-static ptr eval(ptr x) {
- if (Spairp(x)) {
- switch (Schar_value(Scar(x))) {
- case '+': return S_add(First(x), Second(x));
- case '-': return S_sub(First(x), Second(x));
- case '*': return S_mul(First(x), Second(x));
- case '/': return S_div(First(x), Second(x));
- case 'q': return S_trunc(First(x), Second(x));
- case 'r': return S_rem(First(x), Second(x));
- case 'g': return S_gcd(First(x), Second(x));
- case '=': {
- ptr x1 = First(x), x2 = Second(x);
- if (Sfixnump(x1) && Sfixnump(x2))
- return Sboolean(x1 == x2);
- else if (Sbignump(x1) && Sbignump(x2))
- return Sboolean(S_big_eq(x1, x2));
- else return Sfalse;
- }
- case '<': {
- ptr x1 = First(x), x2 = Second(x);
- if (Sfixnump(x1))
- if (Sfixnump(x2))
- return Sboolean(x1 < x2);
- else
- return Sboolean(!BIGSIGN(x2));
- else
- if (Sfixnump(x2))
- return Sboolean(BIGSIGN(x1));
- else
- return Sboolean(S_big_lt(x1, x2));
- }
- case 'f': return Sflonum(S_floatify(First(x)));
- case 'c':
- S_gc(get_thread_context(), UNFIX(First(x)),UNFIX(Second(x)));
- return Svoid;
- case 'd': return S_decode_float(Sflonum_value(First(x)));
- default:
- S_prin1(x);
- putchar('\n');
- printf("unrecognized operator, returning zero\n");
- return FIX(0);
- }
- } else
- return x;
-}
-
-#undef PROMPT
-#undef NOISY
-static void bignum_test(void) {
- ptr x;
- for (;;) {
-#ifdef PROMPT
- putchar('*');
- putchar(' ');
-#endif
- x = read_top();
- if (x == Seof_object) { putchar('\n'); exit(0); }
-#ifdef NOISY
- S_prin1(x);
- putchar('\n');
-#endif
- x = eval(x);
- S_prin1(x);
- putchar('\n');
- }
-}
diff --git a/ta6ob/c/main.c b/ta6ob/c/main.c
deleted file mode 100644
index de8c719..0000000
--- a/ta6ob/c/main.c
+++ /dev/null
@@ -1,376 +0,0 @@
-/* main.c
- * Copyright 1984-2017 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.
- */
-
-#include
-#include
-#include
-#include "scheme.h"
-#include "config.h"
-
-/****
- CUSTOM_INIT may be defined as a function with the signature shown to
- perform boot-time initialization, e.g., registering foreign symbols.
-****/
-#ifndef CUSTOM_INIT
-#define CUSTOM_INIT ((void (*)(void))0)
-#endif /* CUSTOM_INIT */
-
-/****
- ABNORMAL_EXIT may be defined as a function with the signature shown to
- take some action, such as printing a special error message or performing
- a nonlocal exit with longjmp, when the Scheme system exits abnormally,
- i.e., when an unrecoverable error occurs. If left null, the default
- is to call exit(1).
-****/
-#ifndef ABNORMAL_EXIT
-#define ABNORMAL_EXIT ((void (*)(void))0)
-#endif /* ABNORMAL_EXIT */
-
-#ifndef SCHEME_SCRIPT
-#define SCHEME_SCRIPT "scheme-script"
-#endif
-
-static const char *path_last(const char *p) {
- const char *s;
-#ifdef WIN32
- char c;
- if ((c = *p) >= 'a' && c <= 'z' || c >= 'A' && c <= 'Z')
- if (*(p + 1) == ':')
- p += 2;
-
- for (s = p; *s != 0; s += 1)
- if ((c = *s) == '/' || c == '\\') p = ++s;
-#else /* WIN32 */
- for (s = p; *s != 0; s += 1) if (*s == '/') p = ++s;
-#endif /* WIN32 */
- return p;
-}
-
-#if defined(WIN32) && !defined(__MINGW32__)
-#define GETENV Sgetenv
-#define GETENV_FREE free
-int wmain(int argc, wchar_t* wargv[], wchar_t* wenvp[]) {
- const char** argv = (char**)malloc((argc + 1) * sizeof(char*));
- int i;
- for (i = 0; i < argc; i++) {
- wchar_t* warg = wargv[i];
- if (NULL == (argv[i] = Swide_to_utf8(warg))) {
- fprintf_s(stderr, "Invalid argument: %S\n", warg);
- exit(1);
- }
- }
- argv[argc] = NULL;
-#else /* WIN32 */
-#define GETENV getenv
-#define GETENV_FREE (void)
-int main(int argc, const char *argv[]) {
-#endif /* WIN32 */
- int n, new_argc = 1;
-#ifdef SAVEDHEAPS
- int compact = 1, savefile_level = 0;
- const char *savefile = (char *)0;
-#endif /* SAVEDHEAPS */
- const char *execpath = argv[0];
- const char *scriptfile = (char *)0;
- const char *programfile = (char *)0;
- const char *libdirs = (char *)0;
- const char *libexts = (char *)0;
- int status;
- const char *arg;
- int quiet = 0;
- int eoc = 0;
- int optlevel = 0;
- int debug_on_exception = 0;
- int import_notify = 0;
- int compile_imported_libraries = 0;
-#ifdef FEATURE_EXPEDITOR
- int expeditor_enable = 1;
- const char *expeditor_history_file = ""; /* use "" for default location */
-#endif /* FEATURE_EXPEDITOR */
-
- if (strcmp(Skernel_version(), VERSION) != 0) {
- (void) fprintf(stderr, "unexpected shared library version %s for %s version %s\n", Skernel_version(), execpath, VERSION);
- exit(1);
- }
-
- Sscheme_init(ABNORMAL_EXIT);
-
- if (strcmp(path_last(execpath), SCHEME_SCRIPT) == 0) {
- if (argc < 2) {
- (void) fprintf(stderr,"%s requires program-path argument\n", execpath);
- exit(1);
- }
- argv[0] = programfile = argv[1];
- n = 1;
- while (++n < argc) argv[new_argc++] = argv[n];
- } else {
- /* process command-line arguments, registering boot and heap files */
- for (n = 1; n < argc; n += 1) {
- arg = argv[n];
- if (strcmp(arg,"--") == 0) {
- while (++n < argc) argv[new_argc++] = argv[n];
- } else if (strcmp(arg,"-b") == 0 || strcmp(arg,"--boot") == 0) {
- if (++n == argc) {
- (void) fprintf(stderr,"%s requires argument\n", arg);
- exit(1);
- }
- Sregister_boot_file(argv[n]);
- } else if (strcmp(arg,"--eedisable") == 0) {
- #ifdef FEATURE_EXPEDITOR
- expeditor_enable = 0;
- #endif /* FEATURE_EXPEDITOR */
- } else if (strcmp(arg,"--eehistory") == 0) {
- if (++n == argc) {
- (void) fprintf(stderr,"%s requires argument\n", arg);
- exit(1);
- }
- #ifdef FEATURE_EXPEDITOR
- if (strcmp(argv[n], "off") == 0)
- expeditor_history_file = (char *)0;
- else
- expeditor_history_file = argv[n];
- #endif /* FEATURE_EXPEDITOR */
- } else if (strcmp(arg,"-q") == 0 || strcmp(arg,"--quiet") == 0) {
- quiet = 1;
- } else if (strcmp(arg,"--retain-static-relocation") == 0) {
- Sretain_static_relocation();
- } else if (strcmp(arg,"--enable-object-counts") == 0) {
- eoc = 1;
-#ifdef SAVEDHEAPS
- } else if (strcmp(arg,"-c") == 0 || strcmp(arg,"--compact") == 0) {
- compact = !compact;
- } else if (strcmp(arg,"-h") == 0 || strcmp(arg,"--heap") == 0) {
- if (++n == argc) {
- (void) fprintf(stderr,"%s requires argument\n", arg);
- exit(1);
- }
- Sregister_heap_file(argv[n]);
- } else if (strncmp(arg,"-s",2) == 0 &&
- (savefile_level = -2,
- *(arg+2) == 0 ||
- *(arg+3) == 0 &&
- ((savefile_level = *(arg+2) - '+' - 1) == -1 ||
- (savefile_level = *(arg+2) - '0') >= 0 &&
- savefile_level <= 9)) ||
- strncmp(arg,"--saveheap",10) == 0 &&
- (savefile_level = -2,
- *(arg+10) == 0 ||
- *(arg+11) == 0 &&
- ((savefile_level = *(arg+2) - '+' - 1) == -1 ||
- (savefile_level = *(arg+10) - '0') >= 0 &&
- savefile_level <= 9))) {
- if (++n == argc) {
- (void) fprintf(stderr,"%s requires argument\n", arg);
- exit(1);
- }
- savefile = argv[n];
-#else /* SAVEDHEAPS */
- } else if (strcmp(arg,"-c") == 0 || strcmp(arg,"--compact") == 0) {
- fprintf(stderr, "-c and --compact options are not presently supported\n");
- exit(1);
- } else if (strcmp(arg,"-h") == 0 || strcmp(arg,"--heap") == 0) {
- fprintf(stderr, "-h and --heap options are not presently supported\n");
- exit(1);
- } else if (strncmp(arg,"-s",2) == 0 || strncmp(arg,"--saveheap",10) == 0) {
- fprintf(stderr, "-s and --saveheap options are not presently supported\n");
- exit(1);
-#endif /* SAVEDHEAPS */
- } else if (strcmp(arg,"--script") == 0) {
- if (++n == argc) {
- (void) fprintf(stderr,"%s requires argument\n", arg);
- exit(1);
- }
- scriptfile = argv[n];
- while (++n < argc) argv[new_argc++] = argv[n];
- } else if (strcmp(arg,"--optimize-level") == 0) {
- const char *nextarg;
- if (++n == argc) {
- (void) fprintf(stderr,"%s requires argument\n", arg);
- exit(1);
- }
- nextarg = argv[n];
- if (strcmp(nextarg,"0") == 0)
- optlevel = 0;
- else if (strcmp(nextarg,"1") == 0)
- optlevel = 1;
- else if (strcmp(nextarg,"2") == 0)
- optlevel = 2;
- else if (strcmp(nextarg,"3") == 0)
- optlevel = 3;
- else {
- (void) fprintf(stderr,"invalid optimize-level %s\n", nextarg);
- exit(1);
- }
- } else if (strcmp(arg,"--debug-on-exception") == 0) {
- debug_on_exception = 1;
- } else if (strcmp(arg,"--import-notify") == 0) {
- import_notify = 1;
- } else if (strcmp(arg,"--libexts") == 0) {
- if (++n == argc) {
- (void) fprintf(stderr,"%s requires argument\n", arg);
- exit(1);
- }
- libexts = argv[n];
- } else if (strcmp(arg,"--libdirs") == 0) {
- if (++n == argc) {
- (void) fprintf(stderr,"%s requires argument\n", arg);
- exit(1);
- }
- libdirs = argv[n];
- } else if (strcmp(arg,"--compile-imported-libraries") == 0) {
- compile_imported_libraries = 1;
- } else if (strcmp(arg,"--program") == 0) {
- if (++n == argc) {
- (void) fprintf(stderr,"%s requires argument\n", arg);
- exit(1);
- }
- programfile = argv[n];
- while (++n < argc) argv[new_argc++] = argv[n];
- } else if (strcmp(arg,"--help") == 0) {
- fprintf(stderr,"usage: %s [options and files]\n", execpath);
- fprintf(stderr,"options:\n");
- fprintf(stderr," -q, --quiet suppress greeting and prompt\n");
- fprintf(stderr," --script run as shell script\n");
- fprintf(stderr," --program run rnrs program as shell script\n");
-#ifdef WIN32
-#define sep ";"
-#else
-#define sep ":"
-#endif
- fprintf(stderr," --libdirs %s... set library directories\n", sep);
- fprintf(stderr," --libexts %s... set library extensions\n", sep);
- fprintf(stderr," --compile-imported-libraries compile libraries before loading\n");
- fprintf(stderr," --import-notify enable import search messages\n");
- fprintf(stderr," --optimize-level <0 | 1 | 2 | 3> set optimize-level\n");
- fprintf(stderr," --debug-on-exception on uncaught exception, call debug\n");
- fprintf(stderr," --eedisable disable expression editor\n");
- fprintf(stderr," --eehistory expression-editor history file\n");
- fprintf(stderr," --enable-object-counts have collector maintain object counts\n");
- fprintf(stderr," --retain-static-relocation keep reloc info for compute-size, etc.\n");
- fprintf(stderr," -b , --boot load boot file\n");
-// fprintf(stderr," -c, --compact toggle compaction flag\n");
-// fprintf(stderr," -h , --heap load heap file\n");
-// fprintf(stderr," -s[] , --saveheap[] save heap file\n");
- fprintf(stderr," --verbose trace boot/heap search process\n");
- fprintf(stderr," --version print version and exit\n");
- fprintf(stderr," --help print help and exit\n");
- fprintf(stderr," -- pass through remaining args\n");
- exit(0);
- } else if (strcmp(arg,"--verbose") == 0) {
- Sset_verbose(1);
- } else if (strcmp(arg,"--version") == 0) {
- fprintf(stderr,"%s\n", VERSION);
- exit(0);
- } else {
- argv[new_argc++] = arg;
- }
- }
- }
-
- /* must call Sbuild_heap after registering boot and heap files.
- * Sbuild_heap() completes the initialization of the Scheme system
- * and loads the boot or heap files. If no boot or heap files have
- * been registered, the first argument to Sbuild_heap must be a
- * non-null path string; in this case, Sbuild_heap looks for
- * a heap or boot file named .boot, where is the last
- * component of the path. If no heap files are loaded and
- * CUSTOM_INIT is non-null, Sbuild_heap calls CUSTOM_INIT just
- * prior to loading the boot file(s). */
- Sbuild_heap(execpath, CUSTOM_INIT);
-
-#define CALL0(who) Scall0(Stop_level_value(Sstring_to_symbol(who)))
-#define CALL1(who, arg) Scall1(Stop_level_value(Sstring_to_symbol(who)), arg)
-#ifdef FunCRepl
- {
- ptr p;
-
- for (;;) {
- CALL1("display", Sstring("* "));
- p = CALL0("read");
- if (Seof_objectp(p)) break;
- p = CALL1("eval", p);
- if (p != Svoid) CALL1("pretty-print", p);
- }
- CALL0("newline");
- status = 0;
- }
-#else /* FunCRepl */
- if (quiet) {
- CALL1("suppress-greeting", Strue);
- CALL1("waiter-prompt-string", Sstring(""));
- }
- if (eoc) {
- CALL1("enable-object-counts", Strue);
- }
- if (optlevel != 0) {
- CALL1("optimize-level", Sinteger(optlevel));
- }
- if (debug_on_exception != 0) {
- CALL1("debug-on-exception", Strue);
- }
- if (import_notify != 0) {
- CALL1("import-notify", Strue);
- }
- if (libdirs == 0) {
- char *cslibdirs = GETENV("CHEZSCHEMELIBDIRS");
- if (cslibdirs != 0) {
- CALL1("library-directories", Sstring_utf8(cslibdirs, -1));
- GETENV_FREE(cslibdirs);
- }
- } else {
- CALL1("library-directories", Sstring_utf8(libdirs, -1));
- }
- if (libexts == 0) {
- char *cslibexts = GETENV("CHEZSCHEMELIBEXTS");
- if (cslibexts != 0) {
- CALL1("library-extensions", Sstring_utf8(cslibexts, -1));
- GETENV_FREE(cslibexts);
- }
- } else {
- CALL1("library-extensions", Sstring_utf8(libexts, -1));
- }
- if (compile_imported_libraries != 0) {
- CALL1("compile-imported-libraries", Strue);
- }
-#ifdef FEATURE_EXPEDITOR
- /* Senable_expeditor must be called before Scheme_start/Scheme_script (if at all) */
- if (!quiet && expeditor_enable) Senable_expeditor(expeditor_history_file);
-#endif /* FEATURE_EXPEDITOR */
-
- if (scriptfile != (char *)0)
- /* Sscheme_script invokes the value of the scheme-script parameter */
- status = Sscheme_script(scriptfile, new_argc, argv);
- else if (programfile != (char *)0)
- /* Sscheme_program invokes the value of the scheme-program parameter */
- status = Sscheme_program(programfile, new_argc, argv);
- else {
- /* Sscheme_start invokes the value of the scheme-start parameter */
- status = Sscheme_start(new_argc, argv);
- }
-#endif /* FunCRepl */
-
-#ifdef SAVEDHEAPS
- if (status == 0 && savefile != (char *)0) {
- if (compact) Scompact_heap();
- Ssave_heap(savefile, savefile_level);
- }
-#endif /* SAVEDHEAPS */
-
- /* must call Scheme_deinit after saving the heap and before exiting */
- Sscheme_deinit();
-
- exit(status);
-}
diff --git a/ta6ob/c/main.o b/ta6ob/c/main.o
deleted file mode 100644
index 5255463..0000000
Binary files a/ta6ob/c/main.o and /dev/null differ
diff --git a/ta6ob/c/new-io.c b/ta6ob/c/new-io.c
deleted file mode 100644
index cbd2799..0000000
--- a/ta6ob/c/new-io.c
+++ /dev/null
@@ -1,970 +0,0 @@
-/* new-io.c
- * Copyright 1984-2017 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.
- */
-
-#include "system.h"
-#include
-#include
-#include
-#ifdef WIN32
-#include
-#else /* WIN32 */
-#include
-#include
-#include
-#endif /* WIN32 */
-#include
-#include "zlib.h"
-#include "lz4.h"
-#include "lz4hc.h"
-
-/* !!! UNLESS you enjoy spending endless days tracking down race conditions
- !!! involving the garbage collector, please note: DEACTIVATE and
- !!! REACTIVATE or LOCKandDEACTIVATE and REACTIVATEandLOCK should be used
- !!! around operations that can block. While deactivated, the process
- !!! MUST NOT touch any unlocked Scheme objects (ptrs) or allocate any
- !!! new Scheme objects. It helps to bracket only small pieces of code
- !!! with DEACTIVATE/REACTIVATE or LOCKandDEACTIVATE/REACTIVATE_and_LOCK. */
-#ifdef PTHREADS
-/* assume the scheme wrapper has us in a critical section */
-#define DEACTIVATE(tc) if (DISABLECOUNT(tc) == FIX(1)) { deactivate_thread(tc); }
-#define REACTIVATE(tc) if (DISABLECOUNT(tc) == FIX(1)) { reactivate_thread(tc); }
-#define LOCKandDEACTIVATE(tc,bv) if (DISABLECOUNT(tc) == FIX(1)) { Slock_object(bv); deactivate_thread(tc); }
-#define REACTIVATEandUNLOCK(tc,bv) if (DISABLECOUNT(tc) == FIX(1)) { reactivate_thread(tc); Sunlock_object(bv); }
-#else /* PTHREADS */
-#define DEACTIVATE(tc)
-#define REACTIVATE(tc)
-#define LOCKandDEACTIVATE(tc,bv)
-#define REACTIVATEandUNLOCK(tc,bv)
-#endif /* PTHREADS */
-
-/* locally defined functions */
-static ptr new_open_output_fd_helper(const char *filename, INT mode,
- INT flags, INT no_create, INT no_fail, INT no_truncate,
- INT append, INT lock, INT replace, INT compressed);
-static INT lockfile(INT fd);
-static int is_valid_zlib_length(iptr count);
-static int is_valid_lz4_length(iptr count);
-
-/*
- not_ok_is_fatal: !ok definitely implies error, so ignore glzerror
- ok: whether the result of body seems to be ok
- flag: will be set when an error is detected and cleared if no error
- fd: the glzFile object to call glzerror on
- body: the operation we are checking the error on
-*/
-#ifdef EINTR
-/* like FD_EINTR_GUARD and GZ_EINTR_GUARD but ignores EINTR.
- used for calls to close so we don't close a file descriptor that
- might already have been reallocated by a different thread */
-#define FD_GUARD(ok,flag,body) \
- do { body; \
- flag = !(ok) && errno != EINTR; \
- } while (0)
-#define GZ_GUARD(not_ok_is_fatal,ok,flag,fd,body) \
- do { body; \
- if (ok) { flag = 0; } \
- else { \
- INT errnum; \
- S_glzerror((fd),&errnum); \
- S_glzclearerr((fd)); \
- if (errnum == Z_ERRNO) { \
- flag = errno != EINTR; \
- } else { \
- flag = not_ok_is_fatal || errnum != Z_OK; \
- errno = 0; \
- } \
- } \
- } while (0)
-/* like FD_GUARD and GZ_GUARD but spins on EINTR */
-#define FD_EINTR_GUARD(ok,flag,body) \
- do { body; \
- if (ok) { flag = 0; break; } \
- else if (errno != EINTR) { flag = 1; break; } \
- } while (1)
-#define GZ_EINTR_GUARD(not_ok_is_fatal,ok,flag,fd,body) \
- do { body; \
- if (ok) { flag = 0; break; } \
- else { \
- INT errnum; \
- S_glzerror((fd),&errnum); \
- S_glzclearerr((fd)); \
- if (errnum == Z_ERRNO) { \
- if (errno != EINTR) { flag = 1; break; } \
- } else { \
- flag = not_ok_is_fatal || errnum != Z_OK; \
- errno = 0; \
- break; \
- } \
- } \
- } while (1)
-#else /* EINTR */
-#define FD_GUARD(ok,flag,body) do { body; flag = !(ok); } while (0)
-#define GZ_GUARD(not_ok_is_fatal,ok,flag,fd,body) \
- do { body; \
- if (ok) { flag = 0; } \
- else { \
- INT errnum; \
- S_glzerror((fd),&errnum); \
- S_glzclearerr((fd)); \
- if (errnum == Z_ERRNO) { flag = 1; } \
- else { \
- flag = not_ok_is_fatal || errnum != Z_OK; \
- errno = 0; \
- } \
- } \
- } while (0)
-#define FD_EINTR_GUARD FD_GUARD
-#define GZ_EINTR_GUARD GZ_GUARD
-#endif /* EINTR */
-
-#ifndef O_BINARY
-#define O_BINARY 0
-#endif /* O_BINARY */
-
-
-/* These functions are intended for use immediately upon opening
- * (lockfile) fd. They need to be redesigned for general-purpose
- * locking. */
-#ifdef FLOCK
-static INT lockfile(INT fd) { return FLOCK(fd, LOCK_EX); }
-#endif
-#ifdef LOCKF
-static INT lockfile(INT fd) { return lockf(fd, F_LOCK, (off_t)0); }
-#endif
-
-#define MAKE_GZXFILE(x) Sinteger((iptr)x)
-#define GZXFILE_GZFILE(x) ((glzFile)Sinteger_value(x))
-
-INT S_gzxfile_fd(ptr x) {
- return GZXFILE_GZFILE(x)->fd;
-}
-
-glzFile S_gzxfile_gzfile(ptr x) {
- return GZXFILE_GZFILE(x);
-}
-
-ptr S_new_open_input_fd(const char *infilename, IBOOL compressed) {
- char *filename;
- INT saved_errno = 0;
- INT fd, dupfd, error, result, ok, flag;
- glzFile file;
-#ifdef PTHREADS
- ptr tc = get_thread_context();
-#endif
-
- filename = S_malloc_pathname(infilename);
-
- /* NB: don't use infilename, which might point into a Scheme string, after this point */
- DEACTIVATE(tc)
- FD_EINTR_GUARD(fd>=0, error, fd=OPEN(filename,O_BINARY|O_RDONLY,0));
- saved_errno = errno;
- REACTIVATE(tc)
-
- /* NB: don't use free'd filename after this point */
- free(filename);
-
- if (error) {
- ptr str = S_strerror(saved_errno);
- switch (saved_errno) {
- case EACCES:
- return Scons(FIX(OPEN_ERROR_PROTECTION), str);
- case ENOENT:
- return Scons(FIX(OPEN_ERROR_EXISTSNOT), str);
- default:
- return Scons(FIX(OPEN_ERROR_OTHER), str);
- }
- }
-
- if (!compressed) {
- return MAKE_FD(fd);
- }
-
- if ((dupfd = DUP(fd)) == -1) {
- ptr str = S_strerror(errno);
- FD_GUARD(result == 0, error, result = CLOSE(fd));
- return Scons(FIX(OPEN_ERROR_OTHER), str);
- }
-
- DEACTIVATE(tc) /* glzdopen_input reads the magic word from the file */
- if ((file = S_glzdopen_input(dupfd)) == Z_NULL) {
- REACTIVATE(tc)
- FD_GUARD(result == 0, error, result = CLOSE(fd));
- FD_GUARD(result == 0, error, result = CLOSE(dupfd));
- return Scons(FIX(OPEN_ERROR_OTHER), Sstring("unable to allocate compression state (too many open files?)"));
- }
-
- compressed = !S_glzdirect(file);
- REACTIVATE(tc)
-
- if (compressed) {
- FD_GUARD(result == 0, error, result = CLOSE(fd));
- /* box indicates compressed */
- return Sbox(MAKE_GZXFILE(file));
- }
-
- GZ_GUARD(1, ok == 0 || ok == Z_BUF_ERROR, flag, file, ok = S_glzclose(file));
- if (flag) {} /* make the compiler happy */
- if (LSEEK(fd, 0, SEEK_SET) != 0) { /* glzdopen and glzdirect might not leave fd at position 0 */
- FD_GUARD(result == 0, error, result = CLOSE(fd));
- return Scons(FIX(OPEN_ERROR_OTHER),Sstring("unable to reset after reading header bytes"));
- }
- return MAKE_FD(fd);
-}
-
-ptr S_compress_input_fd(INT fd, I64 pos) {
- INT dupfd, error, result, ok, flag; IBOOL compressed;
- glzFile file;
-#ifdef PTHREADS
- ptr tc = get_thread_context();
-#endif
-
- if ((dupfd = DUP(fd)) == -1) {
- return S_strerror(errno);
- }
-
- DEACTIVATE(tc)
- if ((file = S_glzdopen_input(dupfd)) == Z_NULL) {
- REACTIVATE(tc)
- FD_GUARD(result == 0, error, result = CLOSE(dupfd));
- return Sstring("unable to allocate compression state (too many open files?)");
- }
-
- compressed = !S_glzdirect(file);
- REACTIVATE(tc)
-
- if (compressed) {
- FD_GUARD(result == 0, error, result = CLOSE(fd));
- if (error) {} /* make the compiler happy */
- /* box indicates compressed */
- return Sbox(MAKE_GZXFILE(file));
- }
-
- GZ_GUARD(1, ok == 0 || ok == Z_BUF_ERROR, flag, file, ok = S_glzclose(file));
- if (flag) {} /* make the compiler happy */
- if (LSEEK(fd, pos, SEEK_SET) != pos) { /* glzdirect does not leave fd at same position */
- return Sstring("unable to reset after reading header bytes");
- }
- return MAKE_FD(fd);
-}
-
-ptr S_compress_output_fd(INT fd) {
- glzFile file;
- ptr tc = get_thread_context();
-
- file = S_glzdopen_output(fd, (INT)UNFIX(COMPRESSFORMAT(tc)), (INT)UNFIX(COMPRESSLEVEL(tc)));
-
- if (file == Z_NULL)
- return Sstring("unable to allocate compression state (too many open files?)");
-
- /* box indicates compressed */
- return Sbox(MAKE_GZXFILE(file));
-}
-
-static ptr new_open_output_fd_helper(
- const char *infilename, INT mode, INT flags,
- IBOOL no_create, IBOOL no_fail, IBOOL no_truncate,
- IBOOL append, IBOOL lock, IBOOL replace, IBOOL compressed) {
- char *filename;
- INT saved_errno = 0;
- iptr error;
- INT fd, result;
- ptr tc = get_thread_context();
-
- flags |=
- (no_create ? 0 : O_CREAT) |
- ((no_fail || no_create) ? 0 : O_EXCL) |
- (no_truncate ? 0 : O_TRUNC) |
- ((!append) ? 0 : O_APPEND);
-
- filename = S_malloc_pathname(infilename);
-
- if (replace && UNLINK(filename) != 0 && errno != ENOENT) {
- ptr str = S_strerror(errno);
- switch (errno) {
- case EACCES:
- return Scons(FIX(OPEN_ERROR_PROTECTION), str);
- default:
- return Scons(FIX(OPEN_ERROR_OTHER), str);
- }
- }
-
- /* NB: don't use infilename, which might point into a Scheme string, after this point */
- DEACTIVATE(tc)
- FD_EINTR_GUARD(fd >= 0, error, fd = OPEN(filename, flags, mode));
- saved_errno = errno;
- REACTIVATE(tc)
-
- /* NB: don't use free'd filename after this point */
- free(filename);
-
- if (error) {
- ptr str = S_strerror(saved_errno);
- switch (saved_errno) {
- case EACCES:
- return Scons(FIX(OPEN_ERROR_PROTECTION), str);
- case EEXIST:
- return Scons(FIX(OPEN_ERROR_EXISTS), str);
- case ENOENT:
- return Scons(FIX(OPEN_ERROR_EXISTSNOT), str);
- default:
- return Scons(FIX(OPEN_ERROR_OTHER), str);
- }
- }
-
- if (lock) {
- DEACTIVATE(tc)
- error = lockfile(fd);
- saved_errno = errno;
- REACTIVATE(tc)
- if (error) {
- FD_GUARD(result == 0, error, result = CLOSE(fd));
- return Scons(FIX(OPEN_ERROR_OTHER), S_strerror(saved_errno));
- }
- }
-
- if (!compressed) {
- return MAKE_FD(fd);
- }
-
- glzFile file;
- file = S_glzdopen_output(fd, (INT)UNFIX(COMPRESSFORMAT(tc)), (INT)UNFIX(COMPRESSLEVEL(tc)));
- if (file == Z_NULL) {
- FD_GUARD(result == 0, error, result = CLOSE(fd));
- return Scons(FIX(OPEN_ERROR_OTHER), Sstring("unable to allocate compression state"));
- }
-
- return MAKE_GZXFILE(file);
-}
-
-ptr S_new_open_output_fd(
- const char *filename, INT mode,
- IBOOL no_create, IBOOL no_fail, IBOOL no_truncate,
- IBOOL append, IBOOL lock, IBOOL replace, IBOOL compressed) {
- return new_open_output_fd_helper(
- filename, mode, O_BINARY | O_WRONLY,
- no_create, no_fail, no_truncate,
- append, lock, replace, compressed);
-}
-
-ptr S_new_open_input_output_fd(
- const char *filename, INT mode,
- IBOOL no_create, IBOOL no_fail, IBOOL no_truncate,
- IBOOL append, IBOOL lock, IBOOL replace, IBOOL compressed) {
- if (compressed)
- return Sstring("compressed input/output files not supported");
- else
- return new_open_output_fd_helper(
- filename, mode, O_BINARY | O_RDWR,
- no_create, no_fail, no_truncate,
- append, lock, replace, 0);
-}
-
-ptr S_close_fd(ptr file, IBOOL gzflag) {
- INT saved_errno = 0;
- INT ok, flag;
- INT fd = gzflag ? 0 : GET_FD(file);
- glzFile gzfile = gzflag ? GZXFILE_GZFILE(file) : NULL;
-#ifdef PTHREADS
- ptr tc = get_thread_context();
-#endif
-
- /* refuse to close stdin, stdout, and stderr fds */
- if (!gzflag && fd <= 2) return Strue;
-
- /* file is not locked; do not reference after deactivating thread! */
- file = (ptr)-1;
-
- /* NOTE: close automatically releases locks so we don't to call unlock*/
- DEACTIVATE(tc)
- if (!gzflag) {
- FD_GUARD(ok == 0, flag, ok = CLOSE(fd));
- } else {
- /* zlib 1.2.1 returns Z_BUF_ERROR when closing an empty file opened for reading */
- GZ_GUARD(1, ok == 0 || ok == Z_BUF_ERROR, flag, gzfile, ok = S_glzclose(gzfile));
- }
- saved_errno = errno;
- REACTIVATE(tc)
-
- if (!flag) {
- return Strue;
- }
-
- if (gzflag && saved_errno == 0) {
- return Sstring("compression failed");
- }
-
- return S_strerror(saved_errno);
-}
-
-#define GZ_IO_SIZE_T unsigned int
-
-#ifdef WIN32
-#define IO_SIZE_T unsigned int
-static HANDLE hStdin = NULL;
-static iptr read_console(char* buf, unsigned size) {
- static char u8buf[1024];
- static int u8i = 0;
- static int u8n = 0;
- iptr n = 0;
- do {
- for (; size > 0 && u8n > 0; size--, u8n--, n++)
- *buf++ = u8buf[u8i++];
- if (n == 0 && size > 0) {
- wchar_t wbuf[256];
- DWORD wn;
- if (!ReadConsoleW(hStdin, wbuf, 256, &wn, NULL) || wn == 0)
- return 0;
- u8n = WideCharToMultiByte(CP_UTF8, 0, wbuf, wn, u8buf, 1024, NULL, NULL);
- u8i = 0;
- }
- } while (n == 0);
- return n;
-}
-#else /* WIN32 */
-#define IO_SIZE_T size_t
-#endif /* WIN32 */
-
-/* Returns string on error, #!eof on end-of-file and integer-count otherwise */
-ptr S_bytevector_read(ptr file, ptr bv, iptr start, iptr count, IBOOL gzflag) {
- INT saved_errno = 0;
- ptr tc = get_thread_context();
- iptr m, flag = 0;
- INT fd = gzflag ? 0 : GET_FD(file);
- glzFile gzfile = gzflag ? GZXFILE_GZFILE(file) : NULL;
-
- /* file is not locked; do not reference after deactivating thread! */
- file = (ptr)-1;
-
-#if (iptr_bits > 32)
- if ((WIN32 || gzflag) && (unsigned int)count != count) count = 0xffffffff;
-#endif
-
- LOCKandDEACTIVATE(tc, bv)
-#ifdef CHECK_FOR_ROSETTA
- /* If we are running on Apple Silicon under Rosetta 2 translation, work around
- a bug (present in 11.2.3 at least) in its handling of memory page protection
- bits. One of the tasks that Rosetta handles is to appropriately twiddle the
- execute and write bits based on what's happening to the memory in order to
- preserve the illusion that the pages have RWX permissions, whereas Apple
- Silicon enforces a W^X (write XOR execute) model. For some reason, this
- bit-twiddling sometimes fails when the bytevector passed to `read` extends
- onto a page that's currently R-X, causing the `read` to fail with EFAULT
- ("bad address"). By writing to each subsequent page, we force Rosetta to
- do the right magic to the protection bits. (Or at least it makes the error
- go away and all the mats pass.)
- */
- if (is_rosetta) {
- for (iptr idx = start+count; idx > start; idx -= S_pagesize) {
- volatile octet b = BVIT(bv,idx);
- BVIT(bv,idx) = b;
- }
- }
-#endif
-
-#ifdef WIN32
- if (!gzflag && fd == 0 && hStdin != NULL) {
- DWORD error_code;
- SetConsoleCtrlHandler(NULL, TRUE);
- SetLastError(0);
- m = read_console(&BVIT(bv,start), (IO_SIZE_T)count);
- error_code = GetLastError();
- if (m == 0 && error_code == 0x3e3) {
- /* Guard against Windows calling the ConsoleCtrlHandler after we
- * turn it back on by waiting a bit. */
- Sleep(1);
-#ifdef PTHREADS
- /* threaded io.ss doesn't handle interrupts because
- * with-tc-mutex disables them, so bail out. */
- SetConsoleCtrlHandler(NULL, FALSE);
- REACTIVATEandUNLOCK(tc, bv)
- S_noncontinuable_interrupt();
-#else
- KEYBOARDINTERRUPTPENDING(tc) = Strue;
- SOMETHINGPENDING(tc) = Strue;
-#endif
- }
- SetConsoleCtrlHandler(NULL, FALSE);
- } else
-#endif /* WIN32 */
- {
- if (!gzflag) {
- FD_EINTR_GUARD(
- m >= 0 || Sboolean_value(KEYBOARDINTERRUPTPENDING(tc)), flag,
- m = READ(fd,&BVIT(bv,start),(IO_SIZE_T)count));
- } else {
- GZ_EINTR_GUARD(
- 1, m >= 0 || Sboolean_value(KEYBOARDINTERRUPTPENDING(tc)),
- flag, gzfile,
- m = S_glzread(gzfile, &BVIT(bv,start), (GZ_IO_SIZE_T)count));
- }
- }
- saved_errno = errno;
- REACTIVATEandUNLOCK(tc, bv)
-
- if (Sboolean_value(KEYBOARDINTERRUPTPENDING(tc))) {
- return Sstring("interrupt");
- }
-
- if (!flag) {
- return m == 0 ? Seof_object : FIX(m);
- }
-
- if (saved_errno == EAGAIN) {
- return FIX(0);
- }
-
- return S_strerror(saved_errno);
-}
-
-/* Returns:
- string on error, including if not supported,
- n when read,
- 0 on non-blocking and
- #!eof otherwise */
-ptr S_bytevector_read_nb(ptr file, ptr bv, iptr start, iptr count, IBOOL gzflag) {
-#ifdef WIN32
- HANDLE h;
-
- /* assume compressed files are always ready */
- if (gzflag) return FIX(1);
-
- if ((h = (HANDLE)_get_osfhandle(GET_FD(file))) != INVALID_HANDLE_VALUE) {
- switch (GetFileType(h)) {
- case FILE_TYPE_CHAR:
- /* if h is hStdin, PeekConsoleInput can tell us if a key down event
- is waiting, but if it's not a newline, we can't be sure that
- a read will succeed. so PeekConsoleInput is basically useless
- for our purposes. */
- break;
- case FILE_TYPE_PIPE: {
- DWORD bytes;
- if (PeekNamedPipe(h, NULL, 0, NULL, &bytes, NULL) && bytes == 0) return FIX(0);
- /* try the read on error or if bytes > 0 */
- return S_bytevector_read(file, bv, start, count, gzflag);
- }
- default: {
- if (WaitForSingleObject(h, 0) == WAIT_TIMEOUT) return FIX(0);
- /* try the read on error or if bytes > 0 */
- return S_bytevector_read(file, bv, start, count, gzflag);
- }
- }
- }
-
- return Sstring("cannot determine ready status");
-#else /* WIN32 */
- INT fcntl_flags;
- ptr result;
- INT fd;
-
- /* assume compressed files are always ready */
- if (gzflag) return FIX(1);
-
- fd = GET_FD(file);
-
- /* set NOBLOCK for nonblocking read */
- fcntl_flags = fcntl(fd, F_GETFL, 0);
- if (!(fcntl_flags & NOBLOCK)) (void) fcntl(fd, F_SETFL, fcntl_flags | NOBLOCK);
-
- result = S_bytevector_read(file, bv, start, count, gzflag);
-
- /* reset NOBLOCK for normal blocking read */
- if (!(fcntl_flags & NOBLOCK)) (void) fcntl(fd, F_SETFL, fcntl_flags);
-
- return result;
-#endif /* WIN32 */
-}
-
-ptr S_bytevector_write(ptr file, ptr bv, iptr start, iptr count, IBOOL gzflag) {
- iptr i, s, c;
- ptr tc = get_thread_context();
- INT flag = 0, saved_errno = 0;
- INT fd = gzflag ? 0 : GET_FD(file);
- glzFile gzfile = gzflag ? GZXFILE_GZFILE(file) : NULL;
-
- for (s = start, c = count; c > 0; s += i, c -= i) {
- iptr cx = c;
-
-#if (iptr_bits > 32)
- if ((WIN32 || gzflag) && (unsigned int)cx != cx) cx = 0xffffffff;
-#endif
-
- /* if we could know that fd is nonblocking, we wouldn't need to deactivate.
- we could test ioctl, but some other thread could change it before we actually
- get around to writing. */
- LOCKandDEACTIVATE(tc, bv)
- if (gzflag) {
- /* strangely, gzwrite returns 0 on error */
- GZ_EINTR_GUARD(
- i < 0, i > 0 || Sboolean_value(KEYBOARDINTERRUPTPENDING(tc)),
- flag, gzfile,
- i = S_glzwrite(gzfile, &BVIT(bv,s), (GZ_IO_SIZE_T)cx));
- } else {
- FD_EINTR_GUARD(i >= 0 || Sboolean_value(KEYBOARDINTERRUPTPENDING(tc)),
- flag, i = WRITE(fd, &BVIT(bv,s), (IO_SIZE_T)cx));
- }
- saved_errno = errno;
- REACTIVATEandUNLOCK(tc, bv)
-
- if (flag) {
- if (saved_errno == EAGAIN) { flag = 0; }
- break;
- }
-
- /* we escape from loop if keyboard interrupt is pending, but this won't
- do much good until we fix up the interrupt protocol to guarantee
- that the interrupt handler is actually called */
- if (Sboolean_value(KEYBOARDINTERRUPTPENDING(tc))) {
- if (i >= 0) s += i;
- break;
- }
- }
-
- if (!flag) {
- return FIX(s - start);
- }
-
- if (saved_errno == EAGAIN) {
- return FIX(0);
- }
-
- if (gzflag && saved_errno == 0) {
- return Sstring("compression failed");
- }
-
- return S_strerror(saved_errno);
-}
-
-/* S_put_byte is a simplified version of S_bytevector_write for writing one
- byte on unbuffered ports */
-ptr S_put_byte(ptr file, INT byte, IBOOL gzflag) {
- iptr i;
- ptr tc = get_thread_context();
- INT flag = 0, saved_errno = 0;
- INT fd = gzflag ? 0 : GET_FD(file);
- glzFile gzfile = gzflag ? GZXFILE_GZFILE(file) : NULL;
- octet buf[1];
-
- buf[0] = (octet)byte;
-
- DEACTIVATE(tc)
- if (gzflag) {
- /* strangely, gzwrite returns 0 on error */
- GZ_EINTR_GUARD(
- i < 0, i > 0 || Sboolean_value(KEYBOARDINTERRUPTPENDING(tc)),
- flag, gzfile,
- i = S_glzwrite(gzfile, buf, 1));
- } else {
- FD_EINTR_GUARD(i >= 0 || Sboolean_value(KEYBOARDINTERRUPTPENDING(tc)),
- flag, i = WRITE(fd, buf, 1));
- }
- saved_errno = errno;
- REACTIVATE(tc)
-
- if (flag) {
- if (saved_errno == EAGAIN) { flag = 0; }
- }
-
- if (!flag) {
- return FIX(i);
- }
-
- if (saved_errno == EAGAIN) {
- return FIX(0);
- }
-
- if (gzflag && saved_errno == 0) {
- return Sstring("compression failed");
- }
-
- return S_strerror(saved_errno);
-}
-
-ptr S_get_fd_pos(ptr file, IBOOL gzflag) {
- errno = 0;
- if (gzflag) {
- z_off_t offset = S_glzseek(GZXFILE_GZFILE(file), 0, SEEK_CUR);
- if (offset != -1) return Sinteger64(offset);
- } else {
- OFF_T offset = LSEEK(GET_FD(file), 0, SEEK_CUR);
- if (offset != -1) return Sinteger64(offset);
- }
- if (gzflag && errno == 0) return Sstring("compression failed");
- return S_strerror(errno);
-}
-
-/* assume wrapper ensures 0 <= pos <= 2^63-1 */
-ptr S_set_fd_pos(ptr file, ptr pos, IBOOL gzflag) {
- I64 offset64 = S_int64_value("set-file-position", pos);
-
- if (gzflag) {
- z_off_t offset = (z_off_t)offset64;
- if (sizeof(z_off_t) != sizeof(I64))
- if (offset != offset64) return Sstring("invalid position");
- errno = 0;
- if (S_glzseek(GZXFILE_GZFILE(file),offset,SEEK_SET) == offset) return Strue;
- if (errno == 0) return Sstring("compression failed");
- return S_strerror(errno);
- } else {
- OFF_T offset = (OFF_T)offset64;
- if (sizeof(OFF_T) != sizeof(I64))
- if (offset != offset64) return Sstring("invalid position");
- if (LSEEK(GET_FD(file), offset, SEEK_SET) == offset) return Strue;
- return S_strerror(errno);
- }
-}
-
-ptr S_get_fd_non_blocking(ptr file, IBOOL gzflag) {
-#ifdef WIN32
- return Sfalse;
-#else /* WIN32 */
- INT fcntl_flags;
-
- if (gzflag) return Sfalse;
-
- fcntl_flags = fcntl(GET_FD(file), F_GETFL, 0);
-
- if (fcntl_flags == -1) {
- return S_strerror(errno);
- }
-
- return Sboolean(NOBLOCK & fcntl_flags);
-#endif /* WIN32 */
-}
-
-ptr S_set_fd_non_blocking(ptr file, IBOOL x, IBOOL gzflag) {
-#ifdef WIN32
- return Sstring("unsupported");
-#else /* WIN32 */
- iptr fd;
- INT fcntl_flags;
-
- if (gzflag) {
- if (x) return Sstring("Compressed non-blocking ports not supported");
- else return Strue;
- }
-
- fd = GET_FD(file);
- fcntl_flags = fcntl(fd, F_GETFL, 0);
-
- if (fcntl_flags == -1) {
- return S_strerror(errno);
- }
-
- if (x) {
- if (fcntl_flags & NOBLOCK) {
- return Strue;
- }
- if (0 == fcntl(fd, F_SETFL, fcntl_flags | NOBLOCK)) {
- return Strue;
- }
- return S_strerror(errno);
- } else {
- if (!(fcntl_flags & NOBLOCK)) {
- return Strue;
- }
- if (0 == fcntl(fd, F_SETFL, fcntl_flags & ~NOBLOCK)) {
- return Strue;
- }
- return S_strerror(errno);
- }
-#endif /* WIN32 */
-}
-
-ptr S_get_fd_length(ptr file, IBOOL gzflag) {
- struct STATBUF statbuf;
-
- if (gzflag) return Sstring("Not supported on compressed files");
-
- if (FSTAT(GET_FD(file), &statbuf) == 0) {
- return Sinteger64(statbuf.st_size);
- }
-
- return S_strerror(errno);
-}
-
-ptr S_set_fd_length(ptr file, ptr length, IBOOL gzflag) {
- INT fd, ok, flag = 0;
- I64 len64; off_t len;
-#ifdef PTHREADS
- ptr tc = get_thread_context();
-#endif
-
- if (gzflag) return Sstring("Not supported on compressed files");
-
- len64 = S_int64_value("set-file-length", length);
- len = (off_t)len64;
- if (sizeof(off_t) != sizeof(I64))
- if (len != len64) return Sstring("invalid length");
-
- fd = GET_FD(file);
- DEACTIVATE(tc)
- FD_EINTR_GUARD(ok == 0, flag, ok = ftruncate(fd, len));
- REACTIVATE(tc)
-
- return flag ? S_strerror(errno) : Strue;
-}
-
-void S_new_io_init(void) {
- if (S_boot_time) {
- S_set_symbol_value(S_intern((const unsigned char *)"$c-bufsiz"), Sinteger(SBUFSIZ));
- }
-#ifdef WIN32
- { /* Get the console input handle for reading Unicode characters */
- HANDLE h;
- DWORD mode;
- if ((h = GetStdHandle(STD_INPUT_HANDLE)) != INVALID_HANDLE_VALUE
- && GetConsoleMode(h, &mode))
- hStdin = h;
- }
- /* transcoder, if any, does its own cr, lf translations */
- _setmode(_fileno(stdin), O_BINARY);
- _setmode(_fileno(stdout), O_BINARY);
- _setmode(_fileno(stderr), O_BINARY);
- /* Set the console output to handle UTF-8 */
- SetConsoleOutputCP(CP_UTF8);
-#endif /* WIN32 */
-}
-
-static int is_valid_zlib_length(iptr count) {
- /* A zlib `uLong` may be the same as `unsigned long`,
- which is not as big as `iptr` on 64-bit Windows. */
- return count == (iptr)(uLong)count;
-}
-
-static int is_valid_lz4_length(iptr len) {
- return (len <= LZ4_MAX_INPUT_SIZE);
-}
-
-/* Accept `iptr` because we expect it to represent a bytevector size,
- which always fits in `iptr`. Return `uptr`, because the result might
- not fit in `iptr`. */
-uptr S_bytevector_compress_size(iptr s_count, INT compress_format) {
- switch (compress_format) {
- case COMPRESS_GZIP:
- if (is_valid_zlib_length(s_count))
- return compressBound((uLong)s_count);
- else {
- /* Compression will report "source too long" */
- return 0;
- }
- case COMPRESS_LZ4:
- if (is_valid_lz4_length(s_count))
- return LZ4_compressBound((uLong)s_count);
- else {
- /* Compression will report "source too long" */
- return 0;
- }
- default:
- S_error1("S_bytevector_compress_size", "unexpected compress format ~s", FIX(compress_format));
- return 0;
- }
-}
-
-ptr S_bytevector_compress(ptr dest_bv, iptr d_start, iptr d_count,
- ptr src_bv, iptr s_start, iptr s_count,
- INT compress_format) {
- ptr tc = get_thread_context();
- int compress_level = (INT)UNFIX(COMPRESSLEVEL(tc));
-
- /* On error, an message-template string with ~s for the bytevector */
- switch (compress_format) {
- case COMPRESS_GZIP:
- {
- int r;
- uLong destLen;
-
- if (!is_valid_zlib_length(s_count))
- return Sstring("source bytevector ~s is too large");
-
- destLen = (uLong)d_count;
-
- r = compress2(&BVIT(dest_bv, d_start), &destLen, &BVIT(src_bv, s_start), (uLong)s_count, S_zlib_compress_level(compress_level));
-
- if (r == Z_OK)
- return FIX(destLen);
- else if (r == Z_BUF_ERROR)
- return Sstring("destination bytevector is too small for compressed form of ~s");
- else
- return Sstring("internal error compressing ~s");
- }
- case COMPRESS_LZ4:
- {
- int destLen;
-
- if (!is_valid_lz4_length(s_count))
- return Sstring("source bytevector ~s is too large");
-
- if (compress_level == COMPRESS_MIN) {
- destLen = LZ4_compress_default((char *)&BVIT(src_bv, s_start), (char *)&BVIT(dest_bv, d_start), (int)s_count, (int)d_count);
- } else {
- destLen = LZ4_compress_HC((char *)&BVIT(src_bv, s_start), (char *)&BVIT(dest_bv, d_start), (int)s_count, (int)d_count, S_lz4_compress_level(compress_level));
- }
-
- if (destLen > 0)
- return Sfixnum(destLen);
- else
- return Sstring("compression failed for ~s");
- }
- default:
- S_error1("S_bytevector_compress", "unexpected compress format ~s", FIX(compress_format));
- return Sfalse;
- }
-}
-
-ptr S_bytevector_uncompress(ptr dest_bv, iptr d_start, iptr d_count,
- ptr src_bv, iptr s_start, iptr s_count,
- INT compress_format) {
- /* On error, an message-template string with ~s for the bytevector */
- switch (compress_format) {
- case COMPRESS_GZIP:
- {
- int r;
- uLongf destLen;
-
- if (!is_valid_zlib_length(d_count))
- return Sstring("expected result size of uncompressed source ~s is too large");
-
- destLen = (uLongf)d_count;
-
- r = uncompress(&BVIT(dest_bv, d_start), &destLen, &BVIT(src_bv, s_start), (uLong)s_count);
-
- if (r == Z_OK)
- return FIX(destLen);
- else if (r == Z_BUF_ERROR)
- return Sstring("uncompressed ~s is larger than expected size");
- else if (r == Z_DATA_ERROR)
- return Sstring("invalid data in source bytevector ~s");
- else
- return Sstring("internal error uncompressing ~s");
- }
- case COMPRESS_LZ4:
- {
- int r;
-
- if (!is_valid_lz4_length(d_count))
- return Sstring("expected result size of uncompressed source ~s is too large");
-
- r = LZ4_decompress_safe((char *)&BVIT(src_bv, s_start), (char *)&BVIT(dest_bv, d_start), (int)s_count, (int)d_count);
-
- if (r >= 0)
- return Sfixnum(r);
- else
- return Sstring("internal error uncompressing ~s");
- }
- default:
- return Sstring("unexpected compress format ~s");
- }
-}
diff --git a/ta6ob/c/new-io.o b/ta6ob/c/new-io.o
deleted file mode 100644
index a52729a..0000000
Binary files a/ta6ob/c/new-io.o and /dev/null differ
diff --git a/ta6ob/c/nocurses.h b/ta6ob/c/nocurses.h
deleted file mode 100644
index 4b17450..0000000
--- a/ta6ob/c/nocurses.h
+++ /dev/null
@@ -1,24 +0,0 @@
-#ifndef ERR
-# define ERR -1
-#endif
-
-#define setupterm(a, b, e) (*(e) = 0, ERR)
-#define tputs(c, x, f) (f(c))
-
-#define lines 0
-#define columns 0
-
-#define cursor_left 0
-#define cursor_right 0
-#define cursor_up 0
-#define cursor_down 0
-#define enter_am_mode 0
-#define exit_am_mode 0
-#define clr_eos 0
-#define clr_eol 0
-#define clear_screen 0
-#define carriage_return 0
-#define bell 0
-#define scroll_reverse 0
-#define auto_right_margin 0
-#define eat_newline_glitch 0
diff --git a/ta6ob/c/number.c b/ta6ob/c/number.c
deleted file mode 100644
index 105e94c..0000000
--- a/ta6ob/c/number.c
+++ /dev/null
@@ -1,2120 +0,0 @@
-/* number.c
- * Copyright 1984-2017 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.
- */
-
-/*
-***
- * assumptions:
- * bigits are unsigned
- * uptr is either one or two bigits wide
-***
-*/
-
-#include "system.h"
-
-/* locally defined functions */
-static ptr copy_normalize(ptr tc, const bigit *p, iptr len, IBOOL sign);
-static IBOOL abs_big_lt(ptr x, ptr y, iptr xl, iptr yl);
-static IBOOL abs_big_eq(ptr x, ptr y, iptr xl, iptr yl);
-static ptr big_negate(ptr tc, ptr x);
-static ptr big_add_pos(ptr tc, ptr x, ptr y, iptr xl, iptr yl, IBOOL sign);
-static ptr big_add_neg(ptr tc, ptr x, ptr y, iptr xl, iptr yl, IBOOL sign);
-static ptr big_add(ptr tc, ptr x, ptr y, iptr xl, iptr yl, IBOOL xs, IBOOL ys);
-static ptr big_mul(ptr tc, ptr x, ptr y, iptr xl, iptr yl, IBOOL sign);
-static void big_short_trunc(ptr tc, ptr x, bigit s, iptr xl, IBOOL qs, IBOOL rs, ptr *q, ptr *r);
-static void big_trunc(ptr tc, ptr x, ptr y, iptr xl, iptr yl, IBOOL qs, IBOOL rs, ptr *q, ptr *r);
-static INT normalize(bigit *xp, bigit *yp, iptr xl, iptr yl);
-static bigit quotient_digit(bigit *xp, bigit *yp, iptr yl);
-static bigit qhat(bigit *xp, bigit *yp);
-static ptr big_short_gcd(ptr tc, ptr x, bigit y, iptr xl);
-static ptr big_gcd(ptr tc, ptr x, ptr y, iptr xl, iptr yl);
-static ptr s_big_ash(ptr tc, bigit *xp, iptr xl, IBOOL sign, iptr cnt);
-static double big_short_floatify(ptr tc, ptr x, bigit s, iptr xl, IBOOL sign);
-static double big_floatify(ptr tc, ptr x, ptr y, iptr xl, iptr yl, IBOOL sign);
-static double floatify_normalize(bigit *p, iptr e, IBOOL sign, IBOOL sticky);
-static double floatify_ratnum(ptr tc, ptr x);
-static ptr big_logbitp(iptr n, ptr x, iptr xl, IBOOL xs);
-static ptr big_logbit0(ptr tc, ptr origx, iptr n, ptr x, iptr xl, IBOOL xs);
-static ptr big_logbit1(ptr tc, ptr origx, iptr n, ptr x, iptr xl, IBOOL xs);
-static ptr big_logtest(ptr x, ptr y, iptr xl, iptr yl, IBOOL xs, IBOOL ys);
-static ptr big_logand(ptr tc, ptr x, ptr y, iptr xl, iptr yl, IBOOL xs, IBOOL ys);
-static ptr big_logor(ptr tc, ptr x, ptr y, iptr xl, iptr yl, IBOOL xs, IBOOL ys);
-static ptr big_logxor(ptr tc, ptr x, ptr y, iptr xl, iptr yl, IBOOL xs, IBOOL ys);
-
-/* use w/o trailing semicolon */
-#define PREPARE_BIGNUM(tc,x,l)\
- {if (x == FIX(0) || BIGLEN(x) < (l)) x = S_bignum(tc, (l)*2, 0);}
-
-#define bigit_mask (~(bigit)0)
-
-#define IBIGIT_TO_BIGNUM(tc,B,x,cnt,sign) {\
- ibigit _i_ = x;\
- PREPARE_BIGNUM(tc, B, 1)\
- *cnt = 1;\
- BIGIT(B,0) = (*sign = (_i_ < 0)) ? -_i_ : _i_;\
-}
-
-#define UBIGIT_TO_BIGNUM(tc,B,u,cnt) {\
- PREPARE_BIGNUM(tc, B, 1)\
- *cnt = 1;\
- BIGIT(B,0) = u;\
-}
-
-#define IBIGITBIGIT_TO_BIGNUM(tc,B,x,cnt,sign) {\
- ibigitbigit _i_ = x; bigitbigit _u_; bigit _b_;\
- PREPARE_BIGNUM(tc, B, 2)\
- _u_ = (*sign = (_i_ < 0)) ? -_i_ : _i_;\
- if ((_b_ = (_u_ & (bigitbigit)bigit_mask)) == _u_) {\
- *cnt = 1;\
- BIGIT(B,0) = (bigit)_u_;\
- } else {\
- *cnt = 2;\
- BIGIT(B,0) = (bigit)(_u_ >> bigit_bits);\
- BIGIT(B,1) = _b_;\
- }\
-}
-
-#define UBIGITBIGIT_TO_BIGNUM(tc,B,x,cnt) {\
- bigitbigit _u_ = x; bigit _b_;\
- PREPARE_BIGNUM(tc, B, 2)\
- if ((_b_ = (_u_ & (bigitbigit)bigit_mask)) == _u_) {\
- *cnt = 1;\
- BIGIT(B,0) = (bigit)_u_;\
- } else {\
- *cnt = 2;\
- BIGIT(B,0) = (bigit)(_u_ >> bigit_bits);\
- BIGIT(B,1) = _b_;\
- }\
-}
-
-#define U32_bigits (32 / bigit_bits)
-
-#if (U32_bigits == 1)
-#define I32_TO_BIGNUM(tc,B,x,cnt,sign) IBIGIT_TO_BIGNUM(tc,B,x,cnt,sign)
-#define U32_TO_BIGNUM(tc,B,x,cnt) UBIGIT_TO_BIGNUM(tc,B,x,cnt)
-#endif
-
-#if (U32_bigits == 2)
-#define I32_TO_BIGNUM(tc,B,x,cnt,sign) IBIGITBIGIT_TO_BIGNUM(tc,B,x,cnt,sign)
-#define U32_TO_BIGNUM(tc,B,x,cnt) UBIGITBIGIT_TO_BIGNUM(tc,B,x,cnt)
-#endif
-
-#define U64_bigits (64 / bigit_bits)
-
-#if (U64_bigits == 2)
-#define I64_TO_BIGNUM(tc,B,x,cnt,sign) IBIGITBIGIT_TO_BIGNUM(tc,B,x,cnt,sign)
-#define U64_TO_BIGNUM(tc,B,x,cnt) UBIGITBIGIT_TO_BIGNUM(tc,B,x,cnt)
-#endif
-
-#if (U64_bigits == 4)
-see v7.4 number.c for U64_TO_BIGNUM w/U64_bigits == 4
-#endif
-
-#define ptr_bigits (ptr_bits / bigit_bits)
-
-#if (ptr_bigits == 1)
-#define IPTR_TO_BIGNUM(tc,B,x,cnt,sign) IBIGIT_TO_BIGNUM(tc,B,x,cnt,sign)
-#define UPTR_TO_BIGNUM(tc,B,x,cnt) UBIGIT_TO_BIGNUM(tc,B,x,cnt)
-#endif
-
-#if (ptr_bigits == 2)
-#define IPTR_TO_BIGNUM(tc,B,x,cnt,sign) IBIGITBIGIT_TO_BIGNUM(tc,B,x,cnt,sign)
-#define UPTR_TO_BIGNUM(tc,B,x,cnt) UBIGITBIGIT_TO_BIGNUM(tc,B,x,cnt)
-#endif
-
-#define FIXNUM_TO_BIGNUM(tc,B,p,cnt,sign) IPTR_TO_BIGNUM(tc,B,UNFIX(p),cnt,sign)
-
-ptr S_normalize_bignum(ptr x) {
- uptr n = BIGIT(x, 0); iptr len = BIGLEN(x); IBOOL sign = BIGSIGN(x);
-
-#if (ptr_bigits == 1)
- if (len == 1) {
- if (sign) {
- if (n <= -most_negative_fixnum) return FIX(-(iptr)n);
- } else {
- if (n <= most_positive_fixnum) return FIX(n);
- }
- }
-#elif (ptr_bigits == 2)
- if (len == 1)
- return sign ? FIX(-(iptr)n) : FIX(n);
- else if (len == 2) {
- n = (n << bigit_bits) | BIGIT(x, 1);
- if (sign) {
- /* avoid -most-negative-fixnum to avoid bogus Sun compiler warning */
- if (n <= most_positive_fixnum+1) return FIX(-(iptr)n);
- } else {
- if (n <= most_positive_fixnum) return FIX(n);
- }
- }
-#endif
-
- return x;
-}
-
-static ptr copy_normalize(ptr tc, const bigit *p, iptr len, IBOOL sign) {
- bigit *p1; uptr n; ptr b;
-
- for (;;) {
- if ((n = *p) != 0)
- break;
- else if (--len == 0)
- return FIX(0);
- else p++;
- }
-
-#if (ptr_bigits == 1)
- if (len == 1) {
- if (sign) {
- if (n <= -most_negative_fixnum) return FIX(-(iptr)n);
- } else {
- if (n <= most_positive_fixnum) return FIX(n);
- }
- }
-#elif (ptr_bigits == 2)
- if (len == 1)
- return sign ? FIX(-(iptr)n) : FIX(n);
- else if (len == 2) {
- n = (n << bigit_bits) | *(p+1);
- if (sign) {
- /* avoid -most-negative-fixnum to avoid bogus Sun compiler warning */
- if (n <= most_positive_fixnum+1) return FIX(-(iptr)n);
- } else {
- if (n <= most_positive_fixnum) return FIX(n);
- }
- }
-#endif
-
- b = S_bignum(tc, len, sign);
- for (p1 = &BIGIT(b, 0); len--;) *p1++ = *p++;
- return b;
-}
-
-/* -2^(b-1) <= x <= 2^b-1, where b = number of bits in a uptr */
-iptr S_integer_value(const char *who, ptr x) {
- if (Sfixnump(x)) return UNFIX(x);
-
- if (Sbignump(x)) {
- iptr xl; uptr u;
-
- if ((xl = BIGLEN(x)) > ptr_bigits) S_error1(who, "~s is out of range", x);
-
- u = BIGIT(x,0);
-
-#if (ptr_bigits == 2)
- if (xl == 2) u = (u << bigit_bits) | BIGIT(x,1);
-#endif
-
- if (!BIGSIGN(x)) return (iptr)u;
- if (u < ((uptr)1 << (ptr_bits - 1))) return -(iptr)u;
- if (u > ((uptr)1 << (ptr_bits - 1))) S_error1(who, "~s is out of range", x);
-#if (fixnum_bits > 32)
- return (iptr)0x8000000000000000;
-#else
- return (iptr)0x80000000;
-#endif
- }
-
- S_error1(who, "~s is not an integer", x);
-
- return 0 /* not reached */;
-}
-
-/* -2^(b-1) <= x <= 2^b-1, where b = number of bits in a uptr */
-IBOOL S_integer_valuep(ptr x) {
- if (Sfixnump(x)) return 1;
-
- if (Sbignump(x)) {
- iptr xl; uptr u;
-
- if ((xl = BIGLEN(x)) > ptr_bigits) return 0;
-
- u = BIGIT(x,0);
-
-#if (ptr_bigits == 2)
- if (xl == 2) u = (u << bigit_bits) | BIGIT(x,1);
-#endif
-
- if (!BIGSIGN(x)) return 1;
- return u <= ((uptr)1 << (ptr_bits - 1));
- }
-
- return 0;
-}
-
-iptr Sinteger_value(ptr x) {
- return S_integer_value("Sinteger_value", x);
-}
-
-/* -2^31 <= x <= 2^32-1 */
-I32 S_int32_value(char *who, ptr x) {
-#if (fixnum_bits > 32)
- if (Sfixnump(x)) {
- iptr n = UNFIX(x);
- if (n < 0) {
- I32 m = (I32)n;
- if ((iptr)m == UNFIX(x)) return m;
- } else {
- U32 m = (U32)n;
- if ((uptr)m == (uptr)UNFIX(x)) return (I32)m;
- }
- S_error1(who, "~s is out of range", x);
- }
- if (Sbignump(x)) S_error1(who, "~s is out of range", x);
-#else /* (fixnum_bits > 32) */
- if (Sfixnump(x)) return UNFIX(x);
-
- if (Sbignump(x)) {
- iptr xl; U32 u;
-
- if ((xl = BIGLEN(x)) > U32_bigits) S_error1(who, "~s is out of range", x);
-
- u = BIGIT(x,0);
-
-#if (U32_bigits == 2)
- if (xl == 2) u = (u << bigit_bits) | BIGIT(x,1);
-#endif
-
- if (!BIGSIGN(x)) return (I32)u;
- if (u < ((U32)1 << 31)) return -(I32)u;
- if (u > ((U32)1 << 31)) S_error1(who, "~s is out of range", x);
- return (I32)0x80000000;
- }
-#endif /* (fixnum_bits > 32) */
-
- S_error1(who, "~s is not an integer", x);
-
- return 0 /* not reached */;
-}
-
-I32 Sinteger32_value(ptr x) {
- return S_int32_value("Sinteger32_value", x);
-}
-
-/* -2^63 <= x <= 2^64-1 */
-I64 S_int64_value(char *who, ptr x) {
- if (Sfixnump(x)) return UNFIX(x);
-
- if (Sbignump(x)) {
- iptr xl; U64 u;
-
- if ((xl = BIGLEN(x)) > U64_bigits) S_error1(who, "~s is out of range", x);
-
- u = BIGIT(x,0);
-
-#if (U64_bigits == 2)
- if (xl == 2) u = (u << bigit_bits) | BIGIT(x,1);
-#endif
-
- if (!BIGSIGN(x)) return (I64)u;
- if (u < ((U64)1 << 63)) return -(I64)u;
- if (u > ((U64)1 << 63)) S_error1(who, "~s is out of range", x);
- return (I64)0x8000000000000000;
- }
-
- S_error1(who, "~s is not an integer", x);
-
- return 0 /* not reached */;
-}
-
-I64 Sinteger64_value(ptr x) {
- return S_int64_value("Sinteger64_value", x);
-}
-
-ptr Sunsigned(uptr u) { /* convert arg to Scheme integer */
- if (u <= most_positive_fixnum)
- return FIX(u);
- else {
- ptr x = FIX(0); iptr xl;
- UPTR_TO_BIGNUM(get_thread_context(), x, u, &xl)
- SETBIGLENANDSIGN(x, xl, 0);
- return x;
- }
-}
-
-ptr Sinteger(iptr i) { /* convert arg to Scheme integer */
- if (FIXRANGE(i))
- return FIX(i);
- else {
- ptr x = FIX(0); iptr xl; IBOOL xs;
- IPTR_TO_BIGNUM(get_thread_context(), x, i, &xl, &xs)
- SETBIGLENANDSIGN(x, xl, xs);
- return x;
- }
-}
-
-ptr Sunsigned32(U32 u) { /* convert arg to Scheme integer */
-#if (fixnum_bits > 32)
- return FIX((uptr)u);
-#else
- if (u <= most_positive_fixnum)
- return FIX((uptr)u);
- else {
- ptr x = FIX(0); iptr xl;
- U32_TO_BIGNUM(get_thread_context(), x, u, &xl)
- SETBIGLENANDSIGN(x, xl, 0);
- return x;
- }
-#endif
-}
-
-ptr Sinteger32(I32 i) { /* convert arg to Scheme integer */
-#if (fixnum_bits > 32)
- return FIX((iptr)i);
-#else
- if (i > most_negative_fixnum && i <= most_positive_fixnum)
- return FIX((iptr)i);
- else {
- ptr x = FIX(0); iptr xl; IBOOL xs;
- I32_TO_BIGNUM(get_thread_context(), x, i, &xl, &xs)
- SETBIGLENANDSIGN(x, xl, xs);
- return x;
- }
-#endif
-}
-
-ptr Sunsigned64(U64 u) { /* convert arg to Scheme integer */
- if (u <= most_positive_fixnum)
- return FIX((uptr)u);
- else {
- ptr x = FIX(0); iptr xl;
- U64_TO_BIGNUM(get_thread_context(), x, u, &xl)
- SETBIGLENANDSIGN(x, xl, 0);
- return x;
- }
-}
-
-ptr Sinteger64(I64 i) { /* convert arg to Scheme integer */
- if (i > most_negative_fixnum && i <= most_positive_fixnum)
- return FIX((iptr)i);
- else {
- ptr x = FIX(0); iptr xl; IBOOL xs;
- I64_TO_BIGNUM(get_thread_context(), x, i, &xl, &xs)
- SETBIGLENANDSIGN(x, xl, xs);
- return x;
- }
-}
-
-/* extended arithmetic macros: use w/o trailing semicolon */
-#define ELSH(n,x,k) { /* undefined when n == 0 */\
- INT _n_ = (INT)(n); bigit _b_ = *(x), _newk_ = _b_>>(bigit_bits-_n_);\
- *(x) = _b_<<_n_ | *(k);\
- *(k) = _newk_;}
-
-#define ERSH(n,x,k) { /* undefined when n == 0 */\
- INT _n_ = (INT)(n); bigit _b_ = *(x), _newk_ = _b_<<(bigit_bits-_n_);\
- *(x) = _b_>>_n_ | *(k);\
- *(k) = _newk_;}
-
-#define ERSH2(n,x,y,k) { /* undefined when n == 0 */\
- INT _n_ = (INT)(n); bigit _b_ = (x), _newk_ = _b_<<(bigit_bits-_n_);\
- *(y) = _b_>>_n_ | *(k);\
- *(k) = _newk_;}
-
-#define EADDC(a1, a2, sum, k) {\
- bigit _tmp1_, _tmp2_, _tmpk_;\
- _tmp1_ = (a1);\
- _tmp2_ = _tmp1_ + (a2);\
- _tmpk_ = _tmp2_ < _tmp1_;\
- _tmp1_ = _tmp2_ + *(k);\
- *k = _tmpk_ + (_tmp1_ < _tmp2_);\
- *sum = _tmp1_;}
-
-#define ESUBC(s1, s2, diff, b) {\
- bigit _tmp1_, _tmp2_, tmpb;\
- _tmp1_ = (s1);\
- _tmp2_ = _tmp1_ - (s2);\
- tmpb = _tmp2_ > _tmp1_;\
- _tmp1_ = _tmp2_ - *(b);\
- *b = tmpb + (_tmp1_ > _tmp2_);\
- *diff = _tmp1_;}
-
-/* bigit x bigit -> bigitbigit */
-#define EMUL(m1,m2,a1,low,high) {\
- bigitbigit _tmp_;\
- _tmp_ = (bigitbigit)m1 * m2 + a1;\
- *low = (bigit)(_tmp_ & (bigitbigit)bigit_mask);\
- *high = (bigit)(_tmp_ >> bigit_bits);}
-
-/* bigitbigit / bigit -> bigit */
-#define EDIV(high,low,divr,quo,rem) {\
- bigit _tmpr_; bigitbigit _tmp_;\
- _tmp_ = ((bigitbigit)high << bigit_bits) | low;\
- _tmpr_ = divr;\
- *quo = (bigit)(_tmp_ / _tmpr_);\
- *rem = (bigit)(_tmp_ % _tmpr_);}
-
-/*
-***
-comparison
-***
-*/
-
-IBOOL S_big_lt(ptr x, ptr y) {
- if (BIGSIGN(x))
- if (BIGSIGN(y))
- return abs_big_lt(y, x, BIGLEN(y), BIGLEN(x)); /* both negative */
- else
- return 1; /* x negative, y positive */
- else
- if (BIGSIGN(y))
- return 0; /* x positive, y negative */
- else
- return abs_big_lt(x, y, BIGLEN(x), BIGLEN(y)); /* both positive */
-}
-
-IBOOL S_big_eq(ptr x, ptr y) {
- return (BIGSIGN(x) == BIGSIGN(y)) && abs_big_eq(x, y, BIGLEN(x), BIGLEN(y));
-}
-
-static IBOOL abs_big_lt(ptr x, ptr y, iptr xl, iptr yl) {
- if (xl != yl)
- return xl < yl;
- else {
- bigit *xp, *yp;
-
- for (xp = &BIGIT(x,0), yp = &BIGIT(y,0); xl-- > 0; xp++, yp++)
- if (*xp != *yp) return (*xp < *yp);
-
- return 0;
- }
-}
-
-static IBOOL abs_big_eq(ptr x, ptr y, iptr xl, iptr yl) {
- if (xl != yl)
- return 0;
- else {
- bigit *xp, *yp;
-
- for (xp = &BIGIT(x,0), yp = &BIGIT(y,0); xl-- > 0; xp++, yp++)
- if (*xp != *yp) return 0;
-
- return 1;
- }
-}
-
-/*
-***
-addition/subtraction
-***
-*/
-
-static ptr big_negate(ptr tc, ptr x) {
- return copy_normalize(tc, &BIGIT(x,0),BIGLEN(x),!BIGSIGN(x));
-}
-
-ptr S_big_negate(ptr x) {
- return big_negate(get_thread_context(), x);
-}
-
-/* assumptions: BIGLEN(x) >= BIGLEN(y) */
-static ptr big_add_pos(ptr tc, ptr x, ptr y, iptr xl, iptr yl, IBOOL sign) {
- iptr i;
- bigit *xp, *yp, *zp;
- bigit k = 0;
-
- PREPARE_BIGNUM(tc, W(tc),xl+1)
-
- xp = &BIGIT(x,xl-1); yp = &BIGIT(y,yl-1); zp = &BIGIT(W(tc),xl);
-
- for (i = yl; i-- > 0; )
- EADDC(*xp--, *yp--, zp--, &k)
- for (i = xl - yl; k != 0 && i-- > 0; )
- EADDC(*xp--, 0, zp--, &k)
- for (; i-- > 0; )
- *zp-- = *xp--;
-
- *zp = k;
-
- return copy_normalize(tc, zp,xl+1,sign);
-}
-
-/* assumptions: x >= y */
-static ptr big_add_neg(ptr tc, ptr x, ptr y, iptr xl, iptr yl, IBOOL sign) {
- iptr i;
- bigit *xp, *yp, *zp;
- bigit b = 0;
-
- PREPARE_BIGNUM(tc, W(tc),xl)
-
- xp = &BIGIT(x,xl-1); yp = &BIGIT(y,yl-1); zp = &BIGIT(W(tc),xl-1);
-
- for (i = yl; i-- > 0; )
- ESUBC(*xp--, *yp--, zp--, &b)
- for (i = xl-yl; b != 0 && i-- > 0; )
- ESUBC(*xp--, 0, zp--, &b)
- for (; i-- > 0; )
- *zp-- = *xp--;
-
- return copy_normalize(tc, zp+1,xl,sign);
-}
-
-static ptr big_add(ptr tc, ptr x, ptr y, iptr xl, iptr yl, IBOOL xs, IBOOL ys) {
- if (xs == ys)
- if (xl < yl)
- return big_add_pos(tc, y, x, yl, xl, xs);
- else
- return big_add_pos(tc, x, y, xl, yl, xs);
- else
- if (abs_big_lt(x, y, xl, yl))
- return big_add_neg(tc, y, x, yl, xl, ys);
- else
- return big_add_neg(tc, x, y, xl, yl, xs);
-}
-
-/* arguments must be integers, fixnums or bignums */
-ptr S_add(ptr x, ptr y) {
- ptr tc = get_thread_context();
-
- if (Sfixnump(x)) {
- if (Sfixnump(y)) {
- iptr n = UNFIX(x) + UNFIX(y);
- return FIXRANGE(n) ? FIX(n) : Sinteger(n);
- } else {
- iptr xl; IBOOL xs;
- FIXNUM_TO_BIGNUM(tc,X(tc),x,&xl,&xs)
- return big_add(tc, X(tc), y, xl, BIGLEN(y), xs, BIGSIGN(y));
- }
- } else {
- if (Sfixnump(y)) {
- iptr yl; IBOOL ys;
- FIXNUM_TO_BIGNUM(tc,Y(tc),y,&yl,&ys)
- return big_add(tc, x, Y(tc), BIGLEN(x), yl, BIGSIGN(x), ys);
- } else {
- return big_add(tc, x, y, BIGLEN(x), BIGLEN(y), BIGSIGN(x), BIGSIGN(y));
- }
- }
-}
-
-/* arguments must be integers, fixnums or bignums */
-ptr S_sub(ptr x, ptr y) {
- ptr tc = get_thread_context();
-
- if (Sfixnump(x)) {
- if (Sfixnump(y)) {
- iptr n = UNFIX(x) - UNFIX(y);
- return FIXRANGE(n) ? FIX(n) : Sinteger(n);
- } else {
- iptr xl; IBOOL xs;
- FIXNUM_TO_BIGNUM(tc,X(tc),x,&xl,&xs)
- return big_add(tc, X(tc), y, xl, BIGLEN(y), xs, !BIGSIGN(y));
- }
- } else {
- if (Sfixnump(y)) {
- iptr yl; IBOOL ys;
- FIXNUM_TO_BIGNUM(tc,Y(tc),y,&yl,&ys)
- return big_add(tc, x, Y(tc), BIGLEN(x), yl, BIGSIGN(x), !ys);
- } else {
- return big_add(tc, x, y, BIGLEN(x), BIGLEN(y), BIGSIGN(x), !BIGSIGN(y));
- }
- }
-}
-
-/*
-***
-multiplication
-***
-*/
-
-static ptr big_mul(ptr tc, ptr x, ptr y, iptr xl, iptr yl, IBOOL sign) {
- iptr xi, yi;
- bigit *xp, *yp, *zp, *zpa;
- bigit k, k1, prod;
-
- PREPARE_BIGNUM(tc, W(tc),xl+yl)
- for (xi = xl, zp = &BIGIT(W(tc),xl+yl-1); xi-- > 0; ) *zp-- = 0;
-
- for (yi=yl,yp= &BIGIT(y,yl-1),zp= &BIGIT(W(tc),xl+yl-1); yi-- > 0; yp--, zp--)
- if (*yp == 0)
- *(zp-xl) = 0;
- else {
- for (xi=xl,k=0,zpa=zp,xp= &BIGIT(x,xl-1); xi-- > 0; xp--,zpa--) {
- EMUL(*xp, *yp, *zpa, &prod, &k1)
- EADDC(prod, 0, zpa, &k)
- k += k1;
- }
- *zpa = k;
- }
-
- return copy_normalize(tc, &BIGIT(W(tc),0),xl+yl,sign);
-}
-
-/* SHORTRANGE is -floor(sqrt(most_positive_fixnum))..floor(sqrt(most_positive_fixnum)).
- We don't use sqrt because it rounds up for fixnum_bits = 61 */
-#if (fixnum_bits == 30)
-#define SHORTRANGE(x) (-23170 <= (x) && (x) <= 23170)
-#elif (fixnum_bits == 61)
-#define SHORTRANGE(x) (-0x3FFFFFFF <= (x) && (x) <= 0x3FFFFFFF)
-#endif
-
-ptr S_mul(ptr x, ptr y) {
- ptr tc = get_thread_context();
-
- iptr xl, yl; IBOOL xs, ys;
-
- if (Sfixnump(x)) {
- if (Sfixnump(y)) {
- iptr xn = UNFIX(x);
- iptr yn = UNFIX(y);
- if (SHORTRANGE(xn) && SHORTRANGE(yn))
- return FIX(xn * yn);
- else {
- FIXNUM_TO_BIGNUM(tc, X(tc),x,&xl,&xs) x = X(tc);
- FIXNUM_TO_BIGNUM(tc, Y(tc),y,&yl,&ys) y = Y(tc);
- }
- } else {
- FIXNUM_TO_BIGNUM(tc,X(tc),x,&xl,&xs) x = X(tc);
- yl = BIGLEN(y); ys = BIGSIGN(y);
- }
- } else {
- if (Sfixnump(y)) {
- xl = BIGLEN(x); xs = BIGSIGN(x);
- FIXNUM_TO_BIGNUM(tc,Y(tc),y,&yl,&ys) y = Y(tc);
- } else {
- xl = BIGLEN(x); xs = BIGSIGN(x);
- yl = BIGLEN(y); ys = BIGSIGN(y);
- }
- }
- return big_mul(tc, x, y, xl, yl, xs ^ ys);
-}
-
-/*
-***
-division
-***
-*/
-
-/* arguments must be integers (fixnums or bignums), y must be nonzero */
-ptr S_div(ptr x, ptr y) {
- ptr g, n, d;
- ptr tc = get_thread_context();
-
- g = S_gcd(x,y);
- if (Sfixnump(y) ? UNFIX(y) < 0 : BIGSIGN(y)) {
- g = Sfixnump(g) ? Sinteger(-UNFIX(g)) : big_negate(tc, g);
- }
-
- S_trunc_rem(tc, x, g, &n, (ptr *)NULL);
- S_trunc_rem(tc, y, g, &d, (ptr *)NULL);
-
- return S_rational(n, d);
-}
-
-ptr S_trunc(ptr x, ptr y) {
- ptr q;
- S_trunc_rem(get_thread_context(), x, y, &q, (ptr *)NULL);
- return q;
-}
-
-ptr S_rem(ptr x, ptr y) {
- ptr r;
- S_trunc_rem(get_thread_context(), x, y, (ptr *)NULL, &r);
- return r;
-}
-
-/* arguments must be integers (fixnums or bignums), y must be nonzero */
-void S_trunc_rem(ptr tc, ptr origx, ptr y, ptr *q, ptr *r) {
- iptr xl, yl; IBOOL xs, ys; ptr x = origx;
-
- if (Sfixnump(x)) {
- if (Sfixnump(y)) {
- if (x == FIX(most_negative_fixnum) && y == FIX(-1)) {
- iptr m = most_negative_fixnum /* pull out to avoid bogus Sun C warning */;
- if (q != (ptr)NULL) *q = Sinteger(-m);
- if (r != (ptr)NULL) *r = FIX(0);
- return;
- } else {
- if (q != (ptr)NULL) *q = FIX((iptr)x / (iptr)y);
- if (r != (ptr)NULL) *r = (ptr)((iptr)x % (iptr)y);
- return;
- }
- } else {
- FIXNUM_TO_BIGNUM(tc, X(tc),x,&xl,&xs) x = X(tc);
- yl = BIGLEN(y); ys = BIGSIGN(y);
- }
- } else {
- if (Sfixnump(y)) {
- xl = BIGLEN(x); xs = BIGSIGN(x);
- FIXNUM_TO_BIGNUM(tc, Y(tc),y,&yl,&ys) y = Y(tc);
- } else {
- xl = BIGLEN(x); xs = BIGSIGN(x);
- yl = BIGLEN(y); ys = BIGSIGN(y);
- }
- }
-
- if (xl < yl) {
- if (q != (ptr *)NULL) *q = FIX(0);
- if (r != (ptr *)NULL) *r = origx;
- } else if (yl == 1) /* must have two bigits for full algorithm */
- big_short_trunc(tc, x, BIGIT(y,0), xl, xs^ys, xs, q, r);
- else
- big_trunc(tc, x, y, xl, yl, xs^ys, xs, q, r);
-}
-
-/* sparc C compiler barfs w/o full declaration */
-static void big_short_trunc(ptr tc, ptr x, bigit s, iptr xl, IBOOL qs, IBOOL rs, ptr *q, ptr *r) {
- iptr i;
- bigit *xp, *zp;
- bigit k;
-
- PREPARE_BIGNUM(tc, W(tc),xl)
-
- for (i = xl, k = 0, xp = &BIGIT(x,0), zp = &BIGIT(W(tc),0); i-- > 0; )
- EDIV(k, *xp++, s, zp++, &k)
-
- if (q != (ptr *)NULL) *q = copy_normalize(tc, &BIGIT(W(tc),0),xl,qs);
- if (r != (ptr *)NULL) *r = copy_normalize(tc, &k,1,rs);
-}
-
-static void big_trunc(tc, x, y, xl, yl, qs, rs, q, r)
- ptr tc, x, y; iptr xl, yl; IBOOL qs, rs; ptr *q, *r; {
- iptr i;
- bigit *p, *xp, *yp;
- iptr m = xl-yl+1;
- INT d;
- bigit k;
-
- PREPARE_BIGNUM(tc, U(tc), xl+1)
- for (i = xl, xp = &BIGIT(U(tc),xl+1), p = &BIGIT(x,xl); i-- > 0;) *--xp = *--p;
- *--xp = 0;
-
- PREPARE_BIGNUM(tc, V(tc), yl)
- for (i = yl, yp = &BIGIT(V(tc),yl), p = &BIGIT(y,yl); i-- > 0;) *--yp = *--p;
-
- d = normalize(xp, yp, xl, yl);
-
- if (q == (ptr *)NULL) {
- for (i = m; i-- > 0 ; xp++) (void) quotient_digit(xp, yp, yl);
- } else {
- PREPARE_BIGNUM(tc, W(tc),m)
- p = &BIGIT(W(tc),0);
- for (i = m; i-- > 0 ; xp++) *p++ = quotient_digit(xp, yp, yl);
- *q = copy_normalize(tc, &BIGIT(W(tc),0),m,qs);
- }
-
- if (r != (ptr *)NULL) {
- /* unnormalize the remainder */
- if (d != 0) {
- for (i = yl, p = xp, k = 0; i-- > 0; p++) ERSH(d,p,&k)
- }
- *r = copy_normalize(tc, xp, yl, rs);
- }
-}
-
-static INT normalize(bigit *xp, bigit *yp, iptr xl, iptr yl) {
- iptr i;
- bigit *p, k, b;
- INT shft;
-
- for (shft = bigit_bits-1, b = *yp; b >>= 1; shft -= 1);
-
- if (shft != 0) {
- for (i = yl, p = yp+yl-1, k = 0; i-- > 0; p--) ELSH(shft,p,&k)
- for (i = xl, p = xp+xl, k = 0; i-- > 0; p--) ELSH(shft,p,&k)
- *xp = k;
- }
-
- return shft;
-}
-
-static bigit quotient_digit(bigit *xp, bigit *yp, iptr yl) {
- bigit *p1, *p2, q, k, b, prod;
- iptr i;
-
- q = qhat(xp, yp);
-
- for (i = yl, p1 = xp+yl, p2 = yp+yl-1, k = 0, b = 0; i-- > 0; p1--, p2--) {
- EMUL(*p2, q, k, &prod, &k)
- ESUBC(*p1, prod, p1, &b)
- }
-
- ESUBC(*p1, k, p1, &b)
-
- if (b != 0) {
- for (i = yl, p1 = xp+yl, p2 = yp+yl-1, k = 0; i-- > 0; p1--, p2--) {
- EADDC(*p2, *p1, p1, &k)
- }
- EADDC(0,*p1,p1,&k)
- q--;
- }
-
- return q;
-}
-
-static bigit qhat(bigit *xp, bigit *yp) {
- bigit q, r, high, low, k;
-
- k = 0;
-
- if (*xp == *yp) {
- q = bigit_mask;
- EADDC(*(xp+1), *yp, &r, &k)
- } else {
- EDIV(*xp, *(xp+1), *yp, &q, &r)
- }
-
- for (; k == 0; q--) {
- EMUL(*(yp+1), q, 0, &low, &high)
- if (high < r || (high == r && low <= *(xp+2))) break;
- EADDC(r, *yp, &r, &k)
- }
-
- return q;
-}
-
-/*
-***
-gcd
-***
-*/
-
-static ptr uptr_gcd(uptr x, uptr y) {
- uptr r;
-
- while (y != 0) {
- r = x % y;
- x = y;
- y = r;
- }
-
- return Sunsigned(x);
-}
-
-/* sparc C compiler barfs w/o full declaration */
-static ptr big_short_gcd(ptr tc, ptr x, bigit y, iptr xl) {
- bigit *xp;
- iptr i;
- bigit r, q;
-
- if (y == 0) return BIGSIGN(x) ? big_negate(tc, x) : x;
-
- for (i = xl, r = 0, xp = &BIGIT(x,0); i-- > 0; )
- EDIV(r, *xp++, y, &q, &r)
-
- return uptr_gcd((uptr)y,(uptr)r);
-}
-
-static ptr big_gcd(ptr tc, ptr x, ptr y, iptr xl, iptr yl) {
- iptr i;
- INT shft, asc;
- bigit *p, *xp, *yp, k, b;
-
- /* Copy x to scratch bignum, with a leading zero */
- PREPARE_BIGNUM(tc, U(tc),xl+1)
- xp = &BIGIT(U(tc),xl+1);
- for (i = xl, p = &BIGIT(x,xl); i-- > 0; ) *--xp = *--p;
- *--xp = 0; /* leave xp pointing at leading 0-bigit */
-
- /* Copy y to scratch bignum, with a leading zero */
- PREPARE_BIGNUM(tc, V(tc),yl+1)
- yp = &BIGIT(V(tc),yl+1);
- for (i = yl, p = &BIGIT(y,yl); i-- > 0; ) *--yp = *--p;
- *(yp-1) = 0; /* leave yp pointing just after leading 0-bigit */
-
- /* initialize aggregate shift count (asc) */
- asc = 0;
-
- for (;;) {
- /* find number of leading zeros in first bigit of y */
- for (shft = bigit_bits - 1, b = *yp; b >>= 1; shft--);
-
- /* find directed distance to shift and new asc */
- if (asc+shft >= bigit_bits) shft -= bigit_bits;
- asc += shft;
-
- /* shift left or right; adjust lengths, xp and yp */
- if (shft < 0) { /* shift right */
- for (i = yl--, p = yp++, k = 0; i-- > 0; p++) ERSH(-shft,p,&k)
- for (i = xl+1, p = xp, k = 0; i-- > 0; p++) ERSH(-shft,p,&k)
- /* don't need two leading zeros */
- if (*(xp+1) == 0) xp++, xl--;
- /* we have shrunk y, so test the length here */
- if (yl == 1) break;
- } else if (shft > 0) { /* left shift */
- for (i=yl, p=yp+yl-1, k=0; i-- > 0; p--) ELSH(shft,p,&k)
- for (i=xl+1, p=xp+xl, k=0; i-- > 0; p--) ELSH(shft,p,&k)
- }
-
- /* destructive remainder x = x rem y */
- for (i = xl-yl+1; i-- > 0; xp++) (void) quotient_digit(xp, yp, yl);
-
- /* strip leading zero bigits. remainder is at most yl bigits long */
- for (i = yl ; *xp == 0 && i > 0; xp++, i--);
-
- /* swap x and y */
- p = yp; /* leading bigit of y */
- yp = xp; /* remainder */
- xp = p-1; /* new dividend w/leading zero */
- xl = yl;
- yl = i;
-
- /* may have lopped off all or all but one bigit of the remainder */
- if (yl <= 1) break;
- }
-
- /* point xp after the leading zero */
- xp += 1;
-
- /* if y is already zero, shift x and leave */
- if (yl == 0) {
- if (asc != 0) {
- for (i = xl, p = xp, k = 0; i-- > 0; p++) ERSH(asc,p,&k)
- }
- return copy_normalize(tc, xp,xl,0);
- } else {
- bigit d, r;
-
- d = *yp;
- for (r = 0; xl-- > 0; xp++) EDIV(r, *xp, d, xp, &r)
- return uptr_gcd((uptr)(d>>asc), (uptr)(r>>asc));
- }
-}
-
-ptr S_gcd(ptr x, ptr y) {
- ptr tc = get_thread_context();
- iptr xl, yl; IBOOL xs, ys;
-
- if (Sfixnump(x))
- if (Sfixnump(y)) {
- iptr xi = UNFIX(x), yi = UNFIX(y);
- if (xi < 0) xi = -xi;
- if (yi < 0) yi = -yi;
- return xi >= yi ?
- uptr_gcd((uptr)xi, (uptr)yi) :
- uptr_gcd((uptr)yi, (uptr)xi);
- } else {
- FIXNUM_TO_BIGNUM(tc, X(tc),x,&xl,&xs) x = X(tc);
- yl = BIGLEN(y); ys = BIGSIGN(y);
- }
- else
- if (Sfixnump(y)) {
- xl = BIGLEN(x); xs = BIGSIGN(x);
- FIXNUM_TO_BIGNUM(tc, Y(tc),y,&yl,&ys) y = Y(tc);
- } else {
- xl = BIGLEN(x); xs = BIGSIGN(x);
- yl = BIGLEN(y); ys = BIGSIGN(y);
- }
-
- if (xl == 1)
- if (yl == 1) {
- uptr xu = BIGIT(x,0), yu = BIGIT(y,0);
- return xu >= yu ? uptr_gcd(xu, yu) : uptr_gcd(yu, xu);
- } else
- return big_short_gcd(tc, y, BIGIT(x,0), yl);
- else
- if (yl == 1)
- return big_short_gcd(tc, x, BIGIT(y,0), xl);
- else
- if (abs_big_lt(x, y, xl, yl))
- return big_gcd(tc, y, x, yl, xl);
- else
- return big_gcd(tc, x, y, xl, yl);
-}
-
-/*
-***
-floating-point operations
-***
-*/
-
-#ifdef IEEE_DOUBLE
-/* exponent stored + 1024, hidden bit to left of decimal point */
-#define bias 1023
-#define bitstoright 52
-#define m1mask 0xf
-#ifdef WIN32
-#define hidden_bit 0x10000000000000
-#else
-#define hidden_bit 0x10000000000000ULL
-#endif
-#ifdef LITTLE_ENDIAN_IEEE_DOUBLE
-struct dblflt {
- UINT m4: 16;
- UINT m3: 16;
- UINT m2: 16;
- UINT m1: 4;
- UINT e: 11;
- UINT sign: 1;
-};
-#else
-struct dblflt {
- UINT sign: 1;
- UINT e: 11;
- UINT m1: 4;
- UINT m2: 16;
- UINT m3: 16;
- UINT m4: 16;
-};
-#endif
-#endif
-
-double S_random_double(U32 m1, U32 m2, U32 m3, U32 m4, double scale) {
- /* helper for s_fldouble in prim5.c */
- union dxunion {
- double d;
- struct dblflt x;
- } dx;
-
- dx.x.m1 = m1 >> 16 & m1mask;
- dx.x.m2 = m2 >> 16;
- dx.x.m3 = m3 >> 16;
- dx.x.m4 = m4 >> 16;
- dx.x.sign = 0;
- dx.x.e = bias;
- return (dx.d - 1.0) * scale;
-}
-
-/* number of quotient bigits to guarantee at least 64 bits */
-/* +2 since first bigit may be zero and second may not be full */
-#define enough (64 / bigit_bits + 2)
-
-/* sparc C compiler barfs w/o full declaration */
-static double big_short_floatify(ptr tc, ptr x, bigit s, iptr xl, IBOOL sign) {
- iptr i;
- bigit *xp, *zp, k;
-
- PREPARE_BIGNUM(tc, W(tc),enough+1)
-
- /* compute only as much of quotient as we need */
- for (i = 0, k = 0, xp = &BIGIT(x,0), zp = &BIGIT(W(tc),0); i < enough; i++)
- if (i < xl)
- EDIV(k, *xp++, s, zp++, &k)
- else
- EDIV(k, 0, s, zp++, &k)
-
- /* then see if there's a bit set somewhere beyond */
- while (k == 0 && i++ < xl) k = *xp++;
-
- return floatify_normalize(&BIGIT(W(tc),0), xl*bigit_bits, sign, k != 0);
-}
-
-static double big_floatify(ptr tc, ptr x, ptr y, iptr xl, iptr yl, IBOOL sign) {
- iptr i, ul;
- bigit *p, *xp, *yp, k;
-
- /* copy x to U(tc), scaling with added zero bigits as necessary */
- ul = xl < yl + enough-1 ? yl + enough-1 : xl;
- PREPARE_BIGNUM(tc, U(tc), ul+1)
- for (i = ul - xl, xp = &BIGIT(U(tc),ul+1); i-- > 0;) *--xp = 0;
- for (i = xl, p = &BIGIT(x,xl); i-- > 0;) *--xp = *--p;
- *--xp = 0;
-
- /* copy y to V(tc) */
- PREPARE_BIGNUM(tc, V(tc), yl)
- for (i = yl, yp = &BIGIT(V(tc),yl), p = &BIGIT(y,yl); i-- > 0;) *--yp = *--p;
-
- (void) normalize(xp, yp, ul, yl);
-
- PREPARE_BIGNUM(tc, W(tc),4)
- p = &BIGIT(W(tc),0);
-
- /* compute 'enough' bigits of the quotient */
- for (i = enough; i-- > 0; xp++) *p++ = quotient_digit(xp, yp, yl);
-
- /* set k if remainder is nonzero */
- k = 0;
- for (i = ul + 1, xp = &BIGIT(U(tc),ul); k == 0 && i-- > 0; xp--) k = *xp;
-
- return floatify_normalize(&BIGIT(W(tc),0), (xl-yl+1)*bigit_bits, sign, k != 0);
-}
-
-/* come in with exactly 'enough' bigits */
-static double floatify_normalize(bigit *p, iptr e, IBOOL sign, IBOOL sticky) {
- /* *p: first bigit; e: exponent; sign: sign; sticky: sticky bit */
- union dxunion {
- double d;
- struct dblflt x;
- } dx;
- bigit mhigh;
- U64 mlow;
- IBOOL cutbit = 0;
- INT n;
-
- /* shift in what we need, plus at least one bit */
- mhigh = 0; mlow = 0; n = enough;
- while (mhigh == 0 && mlow < hidden_bit * 2) {
- mhigh = (bigit)(mlow >> (64-bigit_bits));
- mlow = (mlow << bigit_bits) | *p++;
- n -= 1;
- e -= bigit_bits;
- }
-
- /* back up to align high bit on hidden bit, setting cut bit to last loser */
- do {
- sticky = sticky || cutbit;
- cutbit = (bigit)(mlow & 1);
- mlow = (U64)mhigh << 63 | mlow >> 1;
- mhigh = mhigh >> 1;
- e = e + 1;
- } while (mhigh != 0 || mlow >= hidden_bit * 2);
-
- e = e + bitstoright + bias;
-
- /* back up further if denormalized */
- if (e <= 0) {
- for (;;) {
- sticky = sticky || cutbit;
- cutbit = (bigit)(mlow & 1);
- mlow = mlow >> 1;
- if (e == 0 || mlow == 0) break;
- e = e + 1;
- }
- }
-
- if (e < 0) {
- e = 0; /* NB: e < 0 => mlow == 0 */
- } else {
- /* round up if necessary */
- if (cutbit) {
- IBOOL round;
- /* cutbit = 1 => at least half way to next number. round up if odd or
- if there are any bits set to the right of cutbit */
- round = (mlow & 1) || sticky;
- while (!round && n-- > 0) round = *p++ != 0;
- if (round) {
- mlow += 1;
- if (e == 0 && mlow == hidden_bit) {
- e = 1; /* squeaking into lowest normalized spot */
- } else if (mlow == hidden_bit * 2) {
- /* don't bother with mlow = mlow >> 1 since hidden bit and up are ignored after this */
- e += 1;
- }
- }
- }
-
- if (e > 2046) { /* infinity */
- e = 2047;
- mlow = 0;
- }
- }
-
- /* fill in the fields */
- dx.x.sign = sign;
- dx.x.e = (UINT)e;
- dx.x.m1 = (UINT)(mlow >> 48 & m1mask);
- dx.x.m2 = (UINT)(mlow >> 32 & 0xffff);
- dx.x.m3 = (UINT)(mlow >> 16 & 0xffff);
- dx.x.m4 = (UINT)(mlow & 0xffff);
-
- return dx.d;
-}
-
-static double floatify_ratnum(ptr tc, ptr p) {
- ptr x, y; iptr xl, yl; IBOOL xs;
-
- x = RATNUM(p); y = RATDEN(p);
-
- if (fixnum_bits <= bitstoright && Sfixnump(x) && Sfixnump(y))
- return (double)UNFIX(x) / (double)UNFIX(y);
-
- /* make sure we are dealing with bignums */
- if (Sfixnump(x)) {
- FIXNUM_TO_BIGNUM(tc,X(tc),x,&xl,&xs)
- x = X(tc);
- } else {
- xl = BIGLEN(x);
- xs = BIGSIGN(x);
- }
-
- if (Sfixnump(y)) {
- IBOOL ys;
- FIXNUM_TO_BIGNUM(tc,Y(tc),y,&yl,&ys)
- y = Y(tc);
- } else {
- yl = BIGLEN(y);
- }
-
- /* need second bignum to be at least two bigits for full algorithm */
- if (yl == 1)
- return big_short_floatify(tc, x, BIGIT(y,0), xl, xs);
- else
- return big_floatify(tc, x, y, xl, yl, xs);
-}
-
-double S_floatify(ptr x) {
- ptr tc = get_thread_context();
-
- if (Sflonump(x)) return FLODAT(x);
- else if (Sfixnump(x)) return (double)UNFIX(x);
- else if (Sbignump(x)) return big_short_floatify(tc, x, 1, BIGLEN(x), BIGSIGN(x));
- else if (Sratnump(x)) return floatify_ratnum(tc, x);
- else S_error1("", "~s is not a real number", x);
-
- return 0.0 /* not reached */;
-}
-
-#ifdef IEEE_DOUBLE
-ptr S_decode_float(double d) {
- union dxunion {
- double d;
- struct dblflt x;
- } dx;
- IBOOL s; INT e; U64 m;
- ptr x, p;
-
- /* pick apart the fields */
- dx.d = d;
- s = dx.x.sign;
- e = dx.x.e;
- m = (U64)dx.x.m1 << 48 | (U64)dx.x.m2 << 32 | (U64)dx.x.m3 << 16 | (U64)dx.x.m4;
- if (e != 0) {
- e = e - bias - bitstoright;
- m |= hidden_bit;
- } else if (m != 0) {
- /* denormalized */
- e = 1 - bias - bitstoright;
- }
-
- /* compute significand */
- if (m <= most_positive_fixnum)
- x = FIX((uptr)m);
- else {
- iptr xl;
- x = FIX(0);
- U64_TO_BIGNUM(get_thread_context(), x, m, &xl)
- SETBIGLENANDSIGN(x, xl, 0);
- }
-
- /* construct return vector */
- p = S_vector(3);
- INITVECTIT(p,0) = x;
- INITVECTIT(p, 1) = FIX(e);
- INITVECTIT(p, 2) = s ? FIX(-1) : FIX(1);
- return p;
-}
-#endif
-
-/*
-***
-logical operations
-***
-*/
-
-static ptr s_big_ash(ptr tc, bigit *xp, iptr xl, IBOOL sign, iptr cnt) {
- iptr i;
- bigit *p1, *p2, k;
-
- if (cnt < 0) { /* shift to the right */
- iptr whole_bigits;
-
- /* decrement length to shift by whole bigits */
- if ((xl -= (whole_bigits = (cnt = -cnt) / bigit_bits)) <= 0) return sign ? FIX(-1) : FIX(0);
- cnt -= whole_bigits * bigit_bits;
-
- /* shift by remaining count to scratch bignum, tracking bits shifted off to the right;
- prepare a bignum one larger than probably needed, in case we have to deal with a
- carry bit when rounding down for a negative number */
- PREPARE_BIGNUM(tc, W(tc),xl+1)
- p1 = &BIGIT(W(tc), 0);
- p2 = xp;
- k = 0;
- i = xl;
- if (cnt == 0) {
- do { *p1++ = *p2++; } while (--i > 0);
- } else {
- do { ERSH2(cnt,*p2,p1,&k); p1++; p2++; } while (--i > 0);
- }
-
- if (sign) {
- if (k == 0) {
- /* check for one bits in the shifted-off bigits, looking */
- /* from both ends in an attempt to get out more quickly for what */
- /* seem like the most likely patterns. of course, there might */
- /* be no one bits (in which case this won't help) or they might be */
- /* only in the middle (in which case this will be slower) */
- p2 = (p1 = xp + xl) + whole_bigits;
- while (p1 != p2) {
- if ((k = *p1++) || p1 == p2 || (k = *--p2)) break;
- }
- }
-
- /* round down negative numbers by incrementing the magnitude if any
- one bits were shifted off to the right */
- if (k) {
- p1 = &BIGIT(W(tc), xl - 1);
- for (i = xl, k = 1; k != 0 && i-- > 0; p1 -= 1)
- EADDC(0, *p1, p1, &k)
- if (k) {
- /* add carry bit back; we prepared a large enough bignum,
- and since all of the middle are zero, we don't have to reshift */
- BIGIT(W(tc), xl) = 0;
- BIGIT(W(tc), 0) = 1;
- xl++;
- }
- }
- }
-
- return copy_normalize(tc, &BIGIT(W(tc), 0), xl, sign);
- } else { /* shift to the left */
- iptr xlplus, newxl;
-
- /* determine how many zero bigits to add on the end */
- xlplus = 0;
- while (cnt >= bigit_bits) {
- xlplus += 1;
- cnt -= bigit_bits;
- }
-
- /* maximum total length includes +1 for shift out of top bigit */
- newxl = xl + xlplus + 1;
-
- PREPARE_BIGNUM(tc, W(tc),newxl)
-
- /* fill bigits to right with zero */
- for (i = xlplus, p1 = &BIGIT(W(tc), newxl); i-- > 0; ) *--p1 = 0;
-
- /* shift to the left */
- for (i = xl, p2 = xp + xl, k = 0; i-- > 0; ) {
- *--p1 = *--p2;
- if (cnt != 0) ELSH(cnt, p1, &k);
- }
- *--p1 = k;
-
- return copy_normalize(tc, p1, newxl, sign);
- }
-}
-
-/* x is a bignum or fixnum, n is a fixnum */
-ptr S_ash(ptr x, ptr n) {
- ptr tc = get_thread_context();
- iptr cnt = UNFIX(n);
-
- if (Sfixnump(x)) {
- /* when we get here with a fixnum, we've done what we could in Scheme
- code to avoid use of bignums, so go straight to it. it's difficult to
- do much here anyway since semantics of signed >> are undefined in C */
- iptr xl; IBOOL xs;
-
- FIXNUM_TO_BIGNUM(tc,X(tc),x,&xl,&xs);
- return s_big_ash(tc, &BIGIT(X(tc),0), xl, xs, cnt);
- } else
- return s_big_ash(tc, &BIGIT(x,0), BIGLEN(x), BIGSIGN(x), cnt);
-}
-
-/* x is a bignum */
-ptr S_integer_length(ptr x) {
- iptr a; bigit b;
-
- if (BIGSIGN(x)) x = S_sub(FIX(-1), x);
-
- b = BIGIT(x, 0);
- a = 1;
- while (b >>= 1) a += 1;
-
- return S_add(S_mul(FIX(BIGLEN(x) - 1), FIX(bigit_bits)), FIX(a));
-}
-
-/* x is a bignum */
-ptr S_big_first_bit_set(ptr x) {
- iptr xl = BIGLEN(x);
- bigit *xp = &BIGIT(x, xl);
- bigit b;
- iptr zbigits = 0;
- INT zbits = 0;
-
- /* first bit set in signed magnitude is same as for two's complement,
- since if x ends with k zeros, ~x+1 also ends with k zeros. */
- while ((b = *--xp) == 0) zbigits += 1;
- while ((b & 1) == 0) { zbits += 1; b >>= 1; }
- return S_add(S_mul(FIX(zbigits), FIX(bigit_bits)), FIX(zbits));
-}
-
-/* assumes fxstart - fxend > 0 */
-ptr S_big_positive_bit_field(ptr x, ptr fxstart, ptr fxend) {
- ptr tc = get_thread_context();
- bigit *xp = &BIGIT(x, 0);
- iptr start = UNFIX(fxstart), end = UNFIX(fxend), xl = BIGLEN(x);
- iptr wl, bigits, i;
- bigit *p1, *p2, k;
- uptr bits, maskbits;
-
- /* shift by whole bigits by decrementing length */
- bigits = (unsigned)start / bigit_bits;
- xl -= bigits;
- if (xl <= 0) return FIX(0);
- bits = (unsigned)bigits * bigit_bits;
- start -= bits;
- end -= bits;
-
- /* compute maximum length of result */
- bigits = (unsigned)end / bigit_bits;
- if (xl <= bigits) {
- wl = xl;
- maskbits = 0;
- } else {
- end -= (unsigned)bigits * bigit_bits;
- if (end != 0) {
- wl = bigits + 1;
- maskbits = bigit_bits - end;
- } else {
- wl = bigits;
- maskbits = 0;
- }
- }
-
- /* copy to scratch bignum */
- PREPARE_BIGNUM(tc, W(tc),wl)
- p1 = &BIGIT(W(tc), wl);
- for (i = wl, p2 = xp + xl; i-- > 0; ) *--p1 = *--p2;
-
- /* kill unwanted bits at the top of the first bigit */
- if (maskbits != 0) *p1 = (*p1 << maskbits) >> maskbits;
-
- /* shift by remaining start bits */
- if (start != 0) {
- k = 0;
- for (i = wl; i > 0; i -= 1, p1 += 1) ERSH(start,p1,&k)
- }
-
- return copy_normalize(tc, &BIGIT(W(tc), 0), wl, 0);
-}
-
-/* logical operations simulate two's complement operations using the
- following general strategy:
-
- 1. break into cases based on signs of operands
-
- 2. convert negative operands to two's complement
-
- 3. operate
-
- 4. convert negative results to two's complement and set sign bit.
- sign of result is known based on signs of operands
-
- simplifications are made where possible to reduce number of operations.
-
- # = 2's complement; #x = ~x + 1 = ~(x - 1) if x > 0
-*/
-
-ptr S_logand(ptr x, ptr y) {
- ptr tc = get_thread_context();
-
- if (Sfixnump(x)) {
- if (Sfixnump(y)) {
- return (ptr)((iptr)x & (iptr)y);
- } else {
- iptr xl; IBOOL xs;
- FIXNUM_TO_BIGNUM(tc,X(tc),x,&xl,&xs)
- return big_logand(tc, y, X(tc), BIGLEN(y), xl, BIGSIGN(y), xs);
- }
- } else {
- if (Sfixnump(y)) {
- iptr yl; IBOOL ys;
- FIXNUM_TO_BIGNUM(tc,Y(tc),y,&yl,&ys)
- return big_logand(tc, x, Y(tc), BIGLEN(x), yl, BIGSIGN(x), ys);
- } else {
- if (BIGLEN(x) >= BIGLEN(y))
- return big_logand(tc, x, y, BIGLEN(x), BIGLEN(y), BIGSIGN(x), BIGSIGN(y));
- else
- return big_logand(tc, y, x, BIGLEN(y), BIGLEN(x), BIGSIGN(y), BIGSIGN(x));
- }
- }
-}
-
-/* logand on signed-magnitude bignums
- # = 2's complement; #x = ~x + 1 = ~(x - 1) if x > 0
- s&(x,y) = x&y know result >= 0
- s&(x,-y) = x&#y know result >= 0
- = x&~(y-1)
- s&(-x,y) = s&(y,-x)
- s&(-x,-y) = -(#(#x&#y)) know result < 0
- = -(~(~(x-1)&~(y-1))+1)
- = -(((x-1)|(y-1))+1) de morgan's law
-*/
-
-/* assumes xl >= yl */
-static ptr big_logand(ptr tc, ptr x, ptr y, iptr xl, iptr yl, IBOOL xs, IBOOL ys) {
- iptr i;
- bigit *xp, *yp, *zp;
-
- if (xs == 0) {
- if (ys == 0) {
- PREPARE_BIGNUM(tc, W(tc),yl);
- xp = &BIGIT(x,xl); yp = &BIGIT(y,yl); zp = &BIGIT(W(tc),yl);
- for (i = yl; i > 0; i -= 1) *--zp = *--xp & *--yp;
- return copy_normalize(tc, zp, yl, 0);
- } else {
- bigit yb;
-
- PREPARE_BIGNUM(tc, W(tc),xl);
- xp = &BIGIT(x,xl); yp = &BIGIT(y,yl); zp = &BIGIT(W(tc),xl);
- yb = 1;
- for (i = yl; i > 0; i -= 1) {
- bigit t1 = *--yp, t2 = t1 - yb;
- yb = t2 > t1;
- *--zp = *--xp & ~t2;
- }
- /* yb must be 0, since high-order bigit >= 1. effectively, this
- means ~t2 would be all 1's from here on out. */
- for (i = xl - yl; i > 0; i -= 1) *--zp = *--xp;
- return copy_normalize(tc, zp, xl, 0);
- }
- } else {
- if (ys == 0) {
- bigit xb;
-
- PREPARE_BIGNUM(tc, W(tc),yl);
- xp = &BIGIT(x,xl); yp = &BIGIT(y,yl); zp = &BIGIT(W(tc),yl);
- xb = 1;
- for (i = yl; i > 0; i -= 1) {
- bigit t1 = *--xp, t2 = t1 - xb;
- xb = t2 > t1;
- *--zp = *--yp & ~t2;
- }
- return copy_normalize(tc, zp, yl, 0);
- } else {
- bigit xb, yb, k;
-
- PREPARE_BIGNUM(tc, W(tc),xl+1);
- xp = &BIGIT(x,xl); yp = &BIGIT(y,yl); zp = &BIGIT(W(tc),xl+1);
- k = yb = xb = 1;
- for (i = yl; i > 0; i -= 1) {
- bigit x1, x2, y1, y2, z1, z2;
- x1 = *--xp; x2 = x1 - xb; xb = x2 > x1;
- y1 = *--yp; y2 = y1 - yb; yb = y2 > y1;
- z1 = x2 | y2;
- z2 = z1 + k; k = z2 < z1;
- *--zp = z2;
- }
- for (i = xl - yl; i > 0; i -= 1) {
- bigit x1, x2, z1, z2;
- x1 = *--xp; x2 = x1 - xb; xb = x2 > x1;
- z1 = x2;
- z2 = z1 + k; k = z2 < z1;
- *--zp = z2;
- }
- *--zp = k;
- return copy_normalize(tc, zp, xl+1, 1);
- }
- }
-}
-
-/* logtest is like logand but returns a boolean value */
-
-ptr S_logtest(ptr x, ptr y) {
- ptr tc = get_thread_context();
-
- if (Sfixnump(x)) {
- if (Sfixnump(y)) {
- return Sboolean((iptr)x & (iptr)y);
- } else {
- iptr xl; IBOOL xs;
- FIXNUM_TO_BIGNUM(tc,X(tc),x,&xl,&xs)
- return big_logtest(y, X(tc), BIGLEN(y), xl, BIGSIGN(y), xs);
- }
- } else {
- if (Sfixnump(y)) {
- iptr yl; IBOOL ys;
- FIXNUM_TO_BIGNUM(tc,Y(tc),y,&yl,&ys)
- return big_logtest(x, Y(tc), BIGLEN(x), yl, BIGSIGN(x), ys);
- } else {
- if (BIGLEN(x) >= BIGLEN(y))
- return big_logtest(x, y, BIGLEN(x), BIGLEN(y), BIGSIGN(x), BIGSIGN(y));
- else
- return big_logtest(y, x, BIGLEN(y), BIGLEN(x), BIGSIGN(y), BIGSIGN(x));
- }
- }
-}
-
-/* essentially the same logic as big_logand, but just produces true iff
- logand would return a nonzero value */
-
-/* assumes xl >= yl */
-static ptr big_logtest(ptr x, ptr y, iptr xl, iptr yl, IBOOL xs, IBOOL ys) {
- iptr i;
- bigit *xp, *yp;
-
- if (xs == 0) {
- if (ys == 0) {
- xp = &BIGIT(x,xl); yp = &BIGIT(y,yl);
- for (i = yl; i > 0; i -= 1) if (*--xp & *--yp) return Strue;
- return Sfalse;
- } else {
- bigit yb;
-
- if (xl > yl) return Strue;
- xp = &BIGIT(x,xl); yp = &BIGIT(y,yl);
- yb = 1; i = yl;
- for (;;) {
- bigit t1 = *--yp, t2 = t1 - yb;
- if (*--xp & ~t2) return Strue;
- if (--i == 0) return Sfalse;
- yb = t2 > t1;
- }
- }
- } else {
- if (ys == 0) {
- bigit xb;
-
- xp = &BIGIT(x,xl); yp = &BIGIT(y,yl);
- xb = 1; i = yl;
- for (;;) {
- bigit t1 = *--xp, t2 = t1 - xb;
- if (*--yp & ~t2) return Strue;
- if (--i == 0) return Sfalse;
- xb = t2 > t1;
- }
- } else {
- /* logand of two negative bignums is always nonzero */
- return Strue;
- }
- }
-}
-
-/* k must be a nonnegative fixnum. x may be a bignum or fixnum */
-ptr S_logbitp(ptr k, ptr x) {
- uptr n = UNFIX(k);
-
- if (Sfixnump(x)) {
- if (n >= fixnum_bits)
- return Sboolean((iptr)x < 0);
- else
- return Sboolean((iptr)x & ((iptr)FIX(1) << n));
- } else {
- return big_logbitp(n, x, BIGLEN(x), BIGSIGN(x));
- }
-}
-
-/* similar logic to big_logand */
-
-static ptr big_logbitp(iptr n, ptr x, iptr xl, IBOOL xs) {
- iptr i;
- bigit *xp;
-
- if (xs == 0) {
- i = xl - (n / bigit_bits + 1);
- if (i < 0) return Sfalse;
-
- n = n % bigit_bits;
- return Sboolean(BIGIT(x,i) & (1 << n));
- } else {
- bigit xb;
-
- /* get out quick when 2^n has more bigits than x */
- if (n / bigit_bits >= xl) return Strue;
-
- xp = &BIGIT(x,xl); xb = 1;
- for (i = xl; ; i -= 1) {
- bigit t1 = *--xp, t2 = t1 - xb;
- if (n < bigit_bits) return Sboolean(~t2 & (1 << n));
- xb = t2 > t1;
- n -= bigit_bits;
- }
- }
-}
-
-/* k must be a nonnegative fixnum. x may be a bignum or fixnum */
-ptr S_logbit0(ptr k, ptr x) {
- ptr tc = get_thread_context();
- iptr n = UNFIX(k);
-
- if (Sfixnump(x)) {
- if (n < fixnum_bits - 1) {
- return FIX(UNFIX(x) & ~(1 << n));
- } else {
- iptr xl; IBOOL xs;
-
- FIXNUM_TO_BIGNUM(tc,X(tc),x,&xl,&xs);
- return big_logbit0(tc, x, n, X(tc), xl, xs);
- }
- } else {
- return big_logbit0(tc, x, n, x, BIGLEN(x), BIGSIGN(x));
- }
-}
-
-/* logbit0 on signed-magnitude bignums
- y = 1 << n
- s&(x,~y) = x&~y know result >= 0
- s&(-x,~y) = -#(#x&~y) know result < 0
- = -(~(~(x-1)&~y)+1)
- = -(((x-1)|y)+1)
-*/
-
-/* adapted from big_logor algorithm */
-static ptr big_logbit0(ptr tc, ptr origx, iptr n, ptr x, iptr xl, IBOOL xs) {
- iptr i;
- bigit *xp, *zp;
- iptr yl = (n / bigit_bits) + 1;
-
- if (xs == 0) {
- if (yl > xl) {
- /* we'd just be clearing a bit that's already (virtually) cleared */
- return origx;
- } else {
- PREPARE_BIGNUM(tc, W(tc),xl);
- xp = &BIGIT(x,xl); zp = &BIGIT(W(tc),xl);
- for (;;) {
- if (n < bigit_bits) break;
- *--zp = *--xp;
- n -= bigit_bits;
- }
- *--zp = *--xp & ~(1 << n);
- for (i = xl - yl; i > 0; i -= 1) *--zp = *--xp;
- return copy_normalize(tc, zp,xl,0);
- }
- } else {
- bigit xb, k, x1, x2, z1, z2;
- iptr zl = (yl > xl ? yl : xl) + 1;
-
- PREPARE_BIGNUM(tc, W(tc),zl);
- xp = &BIGIT(x,xl); zp = &BIGIT(W(tc),zl);
- k = xb = 1;
- i = xl;
- for (;;) {
- if (i > 0) { x1 = *--xp; i -= 1; } else x1 = 0;
- x2 = x1 - xb; xb = x2 > x1;
- if (n < bigit_bits) break;
- z1 = x2; z2 = z1 + k; k = z2 < z1;
- *--zp = z2;
- n -= bigit_bits;
- }
- z1 = x2 | (1 << n); z2 = z1 + k; k = z2 < z1;
- *--zp = z2;
- for (; i > 0; i -= 1) {
- x1 = *--xp; x2 = x1 - xb; xb = x2 > x1;
- z1 = x2; z2 = z1 + k; k = z2 < z1;
- *--zp = z2;
- }
- *--zp = k;
- return copy_normalize(tc, zp, zl, 1);
- }
-}
-
-/* k must be a nonnegative fixnum. x may be a bignum or fixnum */
-ptr S_logbit1(ptr k, ptr x) {
- ptr tc = get_thread_context();
- iptr n = UNFIX(k);
-
- if (Sfixnump(x)) {
- if (n < fixnum_bits - 1) {
- return FIX(UNFIX(x) | ((uptr)1 << n));
- } else {
- iptr xl; IBOOL xs;
-
- FIXNUM_TO_BIGNUM(tc,X(tc),x,&xl,&xs);
- return big_logbit1(tc, x, n, X(tc), xl, xs);
- }
- } else {
- return big_logbit1(tc, x, n, x, BIGLEN(x), BIGSIGN(x));
- }
-}
-
-/* adapted from big_logor algorithm */
-static ptr big_logbit1(ptr tc, ptr origx, iptr n, ptr x, iptr xl, IBOOL xs) {
- iptr i;
- bigit *xp, *zp;
- iptr yl = (n / bigit_bits) + 1;
-
- if (xs == 0) {
- bigit x1;
- iptr zl = yl > xl ? yl : xl;
-
- PREPARE_BIGNUM(tc, W(tc),zl);
- xp = &BIGIT(x,xl); zp = &BIGIT(W(tc),zl);
-
- i = xl;
- for (;;) {
- if (i > 0) { x1 = *--xp; i -= 1; } else x1 = 0;
- if (n < bigit_bits) break;
- *--zp = x1;
- n -= bigit_bits;
- }
- *--zp = x1 | (1 << n);
- for (; i > 0; i -= 1) *--zp = *--xp;
- return copy_normalize(tc, zp, zl, 0);
- } else if (yl > xl) {
- /* we'd just be setting a bit that's already (virtually) set */
- return origx;
- } else { /* xl >= yl */
- bigit xb, k, x1, x2, z1, z2;
- iptr zl = xl + 1;
-
- PREPARE_BIGNUM(tc, W(tc),zl);
- xp = &BIGIT(x,xl); zp = &BIGIT(W(tc),zl);
- k = xb = 1;
- for (;;) {
- x1 = *--xp; x2 = x1 - xb; xb = x2 > x1;
- if (n < bigit_bits) break;
- z1 = x2;
- z2 = z1 + k; k = z2 < z1;
- *--zp = z2;
- n -= bigit_bits;
- }
- z1 = x2 & ~(1 << n);
- z2 = z1 + k; k = z2 < z1;
- *--zp = z2;
- for (i = xl - yl; i > 0; i -= 1) {
- x1 = *--xp; x2 = x1 - xb; xb = x2 > x1;
- z1 = x2;
- z2 = z1 + k; k = z2 < z1;
- *--zp = z2;
- }
- *--zp = k;
- return copy_normalize(tc, zp, zl, 1);
- }
-}
-
-ptr S_logor(ptr x, ptr y) {
- ptr tc = get_thread_context();
-
- if (Sfixnump(x)) {
- if (Sfixnump(y)) {
- return (ptr)((iptr)x | (iptr)(y));
- } else {
- iptr xl; IBOOL xs;
- FIXNUM_TO_BIGNUM(tc,X(tc),x,&xl,&xs)
- return big_logor(tc, y, X(tc), BIGLEN(y), xl, BIGSIGN(y), xs);
- }
- } else {
- if (Sfixnump(y)) {
- iptr yl; IBOOL ys;
- FIXNUM_TO_BIGNUM(tc,Y(tc),y,&yl,&ys)
- return big_logor(tc, x, Y(tc), BIGLEN(x), yl, BIGSIGN(x), ys);
- } else {
- if (BIGLEN(x) >= BIGLEN(y))
- return big_logor(tc, x, y, BIGLEN(x), BIGLEN(y), BIGSIGN(x), BIGSIGN(y));
- else
- return big_logor(tc, y, x, BIGLEN(y), BIGLEN(x), BIGSIGN(y), BIGSIGN(x));
- }
- }
-}
-
-/* logor on signed-magnitude bignums
- s|(x,y) = x|y know result >= 0
- s|(x,-y) = -(#(x|#y)) know result < 0
- = -(~(x|~(y-1))+1)
- = -(((y-1)&~x)+1)
- s|(-x,y) = -(((x-1)&~y)+1)
- s|(-x,-y) = -(#(#x|#y)) know result < 0
- = -(~(~(x-1)|~(y-1))+1)
- = -(((x-1)&(y-1))+1) de morgan's law
-*/
-
-/* assumes xl >= yl */
-static ptr big_logor(ptr tc, ptr x, ptr y, iptr xl, iptr yl, IBOOL xs, IBOOL ys) {
- iptr i;
- bigit *xp, *yp, *zp;
-
- if (xs == 0) {
- if (ys == 0) {
- PREPARE_BIGNUM(tc, W(tc),xl);
- xp = &BIGIT(x,xl); yp = &BIGIT(y,yl); zp = &BIGIT(W(tc),xl);
- for (i = yl; i > 0; i -= 1) *--zp = *--xp | *--yp;
- for (i = xl - yl; i > 0; i -= 1) *--zp = *--xp;
- return copy_normalize(tc, zp, xl, 0);
- } else {
- bigit yb, k;
-
- PREPARE_BIGNUM(tc, W(tc),yl+1);
- xp = &BIGIT(x,xl); yp = &BIGIT(y,yl); zp = &BIGIT(W(tc),yl+1);
- k = yb = 1;
- for (i = yl; i > 0; i -= 1) {
- bigit y1, y2, z1, z2;
- y1 = *--yp; y2 = y1 - yb; yb = y2 > y1;
- z1 = y2 & ~*--xp;
- z2 = z1 + k; k = z2 < z1;
- *--zp = z2;
- }
- *--zp = k;
- return copy_normalize(tc, zp, yl+1, 1);
- }
- } else {
- if (ys == 0) {
- bigit xb, k;
-
- PREPARE_BIGNUM(tc, W(tc),xl+1);
- xp = &BIGIT(x,xl); yp = &BIGIT(y,yl); zp = &BIGIT(W(tc),xl+1);
- k = xb = 1;
- for (i = yl; i > 0; i -= 1) {
- bigit x1, x2, z1, z2;
- x1 = *--xp; x2 = x1 - xb; xb = x2 > x1;
- z1 = x2 & ~*--yp;
- z2 = z1 + k; k = z2 < z1;
- *--zp = z2;
- }
- for (i = xl - yl; i > 0; i -= 1) {
- bigit x1, x2, z1, z2;
- x1 = *--xp; x2 = x1 - xb; xb = x2 > x1;
- z1 = x2;
- z2 = z1 + k; k = z2 < z1;
- *--zp = z2;
- }
- *--zp = k;
- return copy_normalize(tc, zp, xl+1, 1);
- } else {
- bigit xb, yb, k;
-
- PREPARE_BIGNUM(tc, W(tc),yl+1);
- xp = &BIGIT(x,xl); yp = &BIGIT(y,yl); zp = &BIGIT(W(tc),yl+1);
- k = yb = xb = 1;
- for (i = yl; i > 0; i -= 1) {
- bigit x1, x2, y1, y2, z1, z2;
- x1 = *--xp; x2 = x1 - xb; xb = x2 > x1;
- y1 = *--yp; y2 = y1 - yb; yb = y2 > y1;
- z1 = x2 & y2;
- z2 = z1 + k; k = z2 < z1;
- *--zp = z2;
- }
- *--zp = k;
- return copy_normalize(tc, zp, yl+1, 1);
- }
- }
-}
-
-ptr S_logxor(ptr x, ptr y) {
- ptr tc = get_thread_context();
-
- if (Sfixnump(x)) {
- if (Sfixnump(y)) {
- return (ptr)((iptr)x ^ (iptr)(y));
- } else {
- iptr xl; IBOOL xs;
- FIXNUM_TO_BIGNUM(tc,X(tc),x,&xl,&xs)
- return big_logxor(tc, y, X(tc), BIGLEN(y), xl, BIGSIGN(y), xs);
- }
- } else {
- if (Sfixnump(y)) {
- iptr yl; IBOOL ys;
- FIXNUM_TO_BIGNUM(tc,Y(tc),y,&yl,&ys)
- return big_logxor(tc, x, Y(tc), BIGLEN(x), yl, BIGSIGN(x), ys);
- } else {
- if (BIGLEN(x) >= BIGLEN(y))
- return big_logxor(tc, x, y, BIGLEN(x), BIGLEN(y), BIGSIGN(x), BIGSIGN(y));
- else
- return big_logxor(tc, y, x, BIGLEN(y), BIGLEN(x), BIGSIGN(y), BIGSIGN(x));
- }
- }
-}
-
-/* logxor on signed-magnitude bignums
- s^(x,y) = x^y know result >= 0
- s^(x,-y) = -(#(x^#y)) know result < 0
- = -(~(x^~(y-1))+1)
- = -((x^(y-1))+1) since ~(a^~b) = a^b
- s^(-x,y) = -((y^(x-1))+1)
- s^(-x,-y) = #x^#y know result >= 0
- = ~(x-1)^~(y-1)
- = (x-1)^(y-1) since ~a^~b = a^b
-*/
-
-/* assumes xl >= yl */
-static ptr big_logxor(ptr tc, ptr x, ptr y, iptr xl, iptr yl, IBOOL xs, IBOOL ys) {
- iptr i;
- bigit *xp, *yp, *zp;
-
- if (xs == 0) {
- if (ys == 0) {
- PREPARE_BIGNUM(tc, W(tc),xl);
- xp = &BIGIT(x,xl); yp = &BIGIT(y,yl); zp = &BIGIT(W(tc),xl);
- for (i = yl; i > 0; i -= 1) *--zp = *--xp ^ *--yp;
- for (i = xl - yl; i > 0; i -= 1) *--zp = *--xp;
- return copy_normalize(tc, zp, xl, 0);
- } else {
- bigit yb, k;
-
- PREPARE_BIGNUM(tc, W(tc),xl+1);
- xp = &BIGIT(x,xl); yp = &BIGIT(y,yl); zp = &BIGIT(W(tc),xl+1);
- k = yb = 1;
- for (i = yl; i > 0; i -= 1) {
- bigit y1, y2, z1, z2;
- y1 = *--yp; y2 = y1 - yb; yb = y2 > y1;
- z1 = *--xp ^ y2;
- z2 = z1 + k; k = z2 < z1;
- *--zp = z2;
- }
- for (i = xl - yl; i > 0; i -= 1) {
- bigit z1, z2;
- z1 = *--xp;
- z2 = z1 + k; k = z2 < z1;
- *--zp = z2;
- }
- *--zp = k;
- return copy_normalize(tc, zp, xl+1, 1);
- }
- } else {
- if (ys == 0) {
- bigit xb, k;
-
- PREPARE_BIGNUM(tc, W(tc),xl+1);
- xp = &BIGIT(x,xl); yp = &BIGIT(y,yl); zp = &BIGIT(W(tc),xl+1);
- k = xb = 1;
- for (i = yl; i > 0; i -= 1) {
- bigit x1, x2, z1, z2;
- x1 = *--xp; x2 = x1 - xb; xb = x2 > x1;
- z1 = *--yp ^ x2;
- z2 = z1 + k; k = z2 < z1;
- *--zp = z2;
- }
- for (i = xl - yl; i > 0; i -= 1) {
- bigit x1, x2, z1, z2;
- x1 = *--xp; x2 = x1 - xb; xb = x2 > x1;
- z1 = x2;
- z2 = z1 + k; k = z2 < z1;
- *--zp = z2;
- }
- *--zp = k;
- return copy_normalize(tc, zp, xl+1, 1);
- } else {
- bigit xb, yb;
-
- PREPARE_BIGNUM(tc, W(tc),xl);
- xp = &BIGIT(x,xl); yp = &BIGIT(y,yl); zp = &BIGIT(W(tc),xl);
- yb = xb = 1;
- for (i = yl; i > 0; i -= 1) {
- bigit x1, x2, y1, y2;
- x1 = *--xp; x2 = x1 - xb; xb = x2 > x1;
- y1 = *--yp; y2 = y1 - yb; yb = y2 > y1;
- *--zp = x2 ^ y2;
- }
- for (i = xl - yl; i > 0; i -= 1) {
- bigit x1, x2;
- x1 = *--xp; x2 = x1 - xb; xb = x2 > x1;
- *--zp = x2;
- }
- return copy_normalize(tc, zp, xl, 0);
- }
- }
-}
-
-/* lognot on signed-magnitude bignums:
- s~(x) = -#~x
- = -(~~x+1)
- = -(x+1)
- s~(-x) = ~#x
- = ~~(x-1)
- = x-1
- therefore:
- (define (lognot x)
- (if (< x 0)
- (- (- x) 1)
- (- (+ x 1))))
- simplifying:
- (define (lognot x) (- -1 x))
-*/
-
-ptr S_lognot(ptr x) {
- if (Sfixnump(x)) {
- return FIX(~UNFIX(x));
- } else {
- return S_sub(FIX(-1), x);
- }
-}
-
-void S_number_init(void) {
- if ((int)(hidden_bit >> 22) != 0x40000000) {
- fprintf(stderr, "hidden_bit >> 22 = %x\n", (int)(hidden_bit >> 22));
- S_abnormal_exit();
- }
-}
diff --git a/ta6ob/c/number.o b/ta6ob/c/number.o
deleted file mode 100644
index e80340a..0000000
Binary files a/ta6ob/c/number.o and /dev/null differ
diff --git a/ta6ob/c/prim.c b/ta6ob/c/prim.c
deleted file mode 100644
index 4cb89d9..0000000
--- a/ta6ob/c/prim.c
+++ /dev/null
@@ -1,288 +0,0 @@
-/* prim.c
- * Copyright 1984-2017 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.
- */
-
-#include "system.h"
-
-/* locally defined functions */
-static void install_library_entry(ptr n, ptr x);
-static void scheme_install_library_entry(void);
-static void create_library_entry_vector(void);
-static void install_c_entry(iptr i, ptr x);
-static void create_c_entry_vector(void);
-static void s_instantiate_code_object(void);
-static void s_link_code_object(ptr co, ptr objs);
-static IBOOL s_check_heap_enabledp(void);
-static void s_enable_check_heap(IBOOL b);
-static uptr s_check_heap_errors(void);
-
-static void install_library_entry(ptr n, ptr x) {
- if (!Sfixnump(n) || UNFIX(n) < 0 || UNFIX(n) >= library_entry_vector_size)
- S_error1("$install-library-entry", "invalid index ~s", n);
- if (!Sprocedurep(x) && !Scodep(x))
- S_error2("$install-library-entry", "invalid entry ~s for ~s", x, n);
- if (Svector_ref(S_G.library_entry_vector, UNFIX(n)) != Sfalse) {
- printf("$install-library-entry: overwriting entry for %ld\n", (long)UNFIX(n));
- fflush(stdout);
- }
- SETVECTIT(S_G.library_entry_vector, UNFIX(n), x);
- if (n == FIX(library_nonprocedure_code)) {
- S_G.nonprocedure_code = x;
- S_retrofit_nonprocedure_code();
- }
-}
-
-ptr S_lookup_library_entry(iptr n, IBOOL errorp) {
- ptr p;
-
- if (n < 0 || n >= library_entry_vector_size)
- S_error1("$lookup-library-entry", "invalid index ~s", FIX(n));
- p = Svector_ref(S_G.library_entry_vector, n);
- if (p == Sfalse && errorp)
- S_error1("$lookup-library-entry", "entry ~s uninitialized", FIX(n));
- return p;
-}
-
-static void scheme_install_library_entry(void) {
- ptr tc = get_thread_context();
- install_library_entry(S_get_scheme_arg(tc, 1), S_get_scheme_arg(tc, 2));
-}
-
-static void create_library_entry_vector(void) {
- iptr i;
-
- S_protect(&S_G.library_entry_vector);
- S_G.library_entry_vector = S_vector(library_entry_vector_size);
- for (i = 0; i < library_entry_vector_size; i++)
- INITVECTIT(S_G.library_entry_vector, i) = Sfalse;
-}
-
-#ifdef HPUX
-#define proc2ptr(x) int2ptr((iptr)(x))
-ptr int2ptr(iptr f)
-{
- if ((f & 2) == 0)
- S_error("proc2ptr", "invalid C procedure");
- return (ptr)(f & ~0x3);
-}
-#else /* HPUX */
-#define proc2ptr(x) (ptr)(iptr)(x)
-#endif /* HPUX */
-
-static void install_c_entry(iptr i, ptr x) {
- if (i < 0 || i >= c_entry_vector_size)
- S_error1("install_c_entry", "invalid index ~s", FIX(i));
- if (Svector_ref(S_G.c_entry_vector, i) != Sfalse)
- S_error1("install_c_entry", "duplicate entry for ~s", FIX(i));
- SETVECTIT(S_G.c_entry_vector, i, x);
-}
-
-ptr S_lookup_c_entry(iptr i) {
- ptr x;
-
- if (i < 0 || i >= c_entry_vector_size)
- S_error1("lookup_c_entry", "invalid index ~s", FIX(i));
- if ((x = Svector_ref(S_G.c_entry_vector, i)) == Sfalse)
- S_error1("lookup_c_entry", "uninitialized entry ~s", FIX(i));
- return x;
-}
-
-static ptr s_get_thread_context(void) {
- return get_thread_context();
-}
-
-static void create_c_entry_vector(void) {
- INT i;
-
- S_protect(&S_G.c_entry_vector);
- S_G.c_entry_vector = S_vector(c_entry_vector_size);
-
- for (i = 0; i < c_entry_vector_size; i++)
- INITVECTIT(S_G.c_entry_vector, i) = Sfalse;
-
- install_c_entry(CENTRY_thread_context, proc2ptr(S_G.thread_context));
- install_c_entry(CENTRY_get_thread_context, proc2ptr(s_get_thread_context));
- install_c_entry(CENTRY_handle_apply_overflood, proc2ptr(S_handle_apply_overflood));
- install_c_entry(CENTRY_handle_docall_error, proc2ptr(S_handle_docall_error));
- install_c_entry(CENTRY_handle_overflow, proc2ptr(S_handle_overflow));
- install_c_entry(CENTRY_handle_overflood, proc2ptr(S_handle_overflood));
- install_c_entry(CENTRY_handle_nonprocedure_symbol, proc2ptr(S_handle_nonprocedure_symbol));
- install_c_entry(CENTRY_thread_list, (ptr)&S_threads);
- install_c_entry(CENTRY_split_and_resize, proc2ptr(S_split_and_resize));
-#ifdef PTHREADS
- install_c_entry(CENTRY_raw_collect_cond, (ptr)&S_collect_cond);
- install_c_entry(CENTRY_raw_tc_mutex, (ptr)&S_tc_mutex);
- install_c_entry(CENTRY_activate_thread, proc2ptr(S_activate_thread));
- install_c_entry(CENTRY_deactivate_thread, proc2ptr(Sdeactivate_thread));
- install_c_entry(CENTRY_unactivate_thread, proc2ptr(S_unactivate_thread));
-#endif /* PTHREADS */
- install_c_entry(CENTRY_handle_values_error, proc2ptr(S_handle_values_error));
- install_c_entry(CENTRY_handle_mvlet_error, proc2ptr(S_handle_mvlet_error));
- install_c_entry(CENTRY_handle_arg_error, proc2ptr(S_handle_arg_error));
- install_c_entry(CENTRY_foreign_entry, proc2ptr(S_foreign_entry));
- install_c_entry(CENTRY_install_library_entry, proc2ptr(scheme_install_library_entry));
- install_c_entry(CENTRY_get_more_room, proc2ptr(S_get_more_room));
- install_c_entry(CENTRY_scan_remembered_set, proc2ptr(S_scan_remembered_set));
- install_c_entry(CENTRY_instantiate_code_object, proc2ptr(s_instantiate_code_object));
- install_c_entry(CENTRY_Sreturn, proc2ptr(S_return));
- install_c_entry(CENTRY_Scall_one_result, proc2ptr(S_call_one_result));
- install_c_entry(CENTRY_Scall_any_results, proc2ptr(S_call_any_results));
-
- for (i = 0; i < c_entry_vector_size; i++) {
-#ifndef PTHREADS
- if (i == CENTRY_raw_collect_cond || i == CENTRY_raw_tc_mutex
- || i == CENTRY_activate_thread || i == CENTRY_deactivate_thread
- || i == CENTRY_unactivate_thread)
- continue;
-#endif /* NOT PTHREADS */
- if (Svector_ref(S_G.c_entry_vector, i) == Sfalse) {
- fprintf(stderr, "c_entry_vector entry %d is uninitialized\n", i);
- S_abnormal_exit();
- }
- }
-}
-
-void S_prim_init(void) {
- if (!S_boot_time) return;
-
- create_library_entry_vector();
- create_c_entry_vector();
-
- Sforeign_symbol("(cs)fixedpathp", (void *)S_fixedpathp);
- Sforeign_symbol("(cs)bytes_allocated", (void *)S_compute_bytes_allocated);
- Sforeign_symbol("(cs)curmembytes", (void *)S_curmembytes);
- Sforeign_symbol("(cs)maxmembytes", (void *)S_maxmembytes);
- Sforeign_symbol("(cs)resetmaxmembytes", (void *)S_resetmaxmembytes);
- Sforeign_symbol("(cs)do_gc", (void *)S_do_gc);
- Sforeign_symbol("(cs)check_heap_enabledp", (void *)s_check_heap_enabledp);
- Sforeign_symbol("(cs)enable_check_heap", (void *)s_enable_check_heap);
- Sforeign_symbol("(cs)check_heap_errors", (void *)s_check_heap_errors);
- Sforeign_symbol("(cs)lookup_library_entry", (void *)S_lookup_library_entry);
- Sforeign_symbol("(cs)link_code_object", (void *)s_link_code_object);
- Sforeign_symbol("(cs)lookup_c_entry", (void *)S_lookup_c_entry);
- Sforeign_symbol("(cs)lock_object", (void *)Slock_object);
- Sforeign_symbol("(cs)unlock_object", (void *)Sunlock_object);
- Sforeign_symbol("(cs)locked_objectp", (void *)Slocked_objectp);
- Sforeign_symbol("(cs)locked_objects", (void *)S_locked_objects);
- Sforeign_symbol("(cs)maxgen", (void *)S_maxgen);
- Sforeign_symbol("(cs)set_maxgen", (void *)S_set_maxgen);
- Sforeign_symbol("(cs)minfreegen", (void *)S_minfreegen);
- Sforeign_symbol("(cs)set_minfreegen", (void *)S_set_minfreegen);
- Sforeign_symbol("(cs)enable_object_counts", (void *)S_enable_object_counts);
- Sforeign_symbol("(cs)set_enable_object_counts", (void *)S_set_enable_object_counts);
- Sforeign_symbol("(cs)object_counts", (void *)S_object_counts);
- Sforeign_symbol("(cs)unregister_guardian", (void *)S_unregister_guardian);
- Sforeign_symbol("(cs)fire_collector", (void *)S_fire_collector);
-}
-
-static void s_instantiate_code_object(void) {
- ptr tc = get_thread_context();
- ptr old, cookie, proc;
- ptr new, oldreloc, newreloc;
- ptr pinfos;
- uptr a, m, n;
- iptr i, size;
-
- old = S_get_scheme_arg(tc, 1);
- cookie = S_get_scheme_arg(tc, 2);
- proc = S_get_scheme_arg(tc, 3);
-
- tc_mutex_acquire()
- new = S_code(tc, CODETYPE(old), CODELEN(old));
- tc_mutex_release()
-
- oldreloc = CODERELOC(old);
- size = RELOCSIZE(oldreloc);
- newreloc = S_relocation_table(size);
- RELOCCODE(newreloc) = new;
- for (i = 0; i < size; i += 1) RELOCIT(newreloc, i) = RELOCIT(oldreloc, i);
-
- CODERELOC(new) = newreloc;
- CODENAME(new) = CODENAME(old);
- CODEARITYMASK(new) = CODEARITYMASK(old);
- CODEFREE(new) = CODEFREE(old);
- CODEINFO(new) = CODEINFO(old);
- CODEPINFOS(new) = pinfos = CODEPINFOS(old);
- if (pinfos != Snil) {
- S_G.profile_counters = Scons(S_weak_cons(new, pinfos), S_G.profile_counters);
- }
-
- for (i = 0; i < CODELEN(old); i++) CODEIT(new,i) = CODEIT(old,i);
-
- m = RELOCSIZE(newreloc);
- a = 0;
- n = 0;
- while (n < m) {
- uptr entry, item_off, code_off; ptr obj;
- entry = RELOCIT(newreloc, n); n += 1;
- if (RELOC_EXTENDED_FORMAT(entry)) {
- item_off = RELOCIT(newreloc, n); n += 1;
- code_off = RELOCIT(newreloc, n); n += 1;
- } else {
- item_off = RELOC_ITEM_OFFSET(entry);
- code_off = RELOC_CODE_OFFSET(entry);
- }
- a += code_off;
- obj = S_get_code_obj(RELOC_TYPE(entry), old, a, item_off);
-
- /* we've seen the enemy, and he is us */
- if (obj == old) obj = new;
-
- /* if we find our cookie, insert proc; otherwise, insert the object
- into new to get proper adjustment of relative addresses */
- if (obj == cookie)
- S_set_code_obj("fcallable", RELOC_TYPE(entry), new, a, proc, item_off);
- else
- S_set_code_obj("fcallable", RELOC_TYPE(entry), new, a, obj, item_off);
- }
- S_flush_instruction_cache(tc);
-
- AC0(tc) = new;
-}
-
-static void s_link_code_object(ptr co, ptr objs) {
- ptr t; uptr a, m, n;
-
- t = CODERELOC(co);
- m = RELOCSIZE(t);
- a = 0;
- n = 0;
- while (n < m) {
- uptr entry, item_off, code_off;
- entry = RELOCIT(t, n); n += 1;
- if (RELOC_EXTENDED_FORMAT(entry)) {
- item_off = RELOCIT(t, n); n += 1;
- code_off = RELOCIT(t, n); n += 1;
- } else {
- item_off = RELOC_ITEM_OFFSET(entry);
- code_off = RELOC_CODE_OFFSET(entry);
- }
- a += code_off;
- S_set_code_obj("gc", RELOC_TYPE(entry), co, a, Scar(objs), item_off);
- objs = Scdr(objs);
- }
-}
-
-static INT s_check_heap_enabledp(void) {
- return S_checkheap;
-}
-
-static void s_enable_check_heap(IBOOL b) {
- S_checkheap = b;
-}
-
-static uptr s_check_heap_errors(void) {
- return S_checkheap_errors;
-}
diff --git a/ta6ob/c/prim.o b/ta6ob/c/prim.o
deleted file mode 100644
index 6702195..0000000
Binary files a/ta6ob/c/prim.o and /dev/null differ
diff --git a/ta6ob/c/prim5.c b/ta6ob/c/prim5.c
deleted file mode 100644
index f552e74..0000000
--- a/ta6ob/c/prim5.c
+++ /dev/null
@@ -1,2052 +0,0 @@
-/* prim5.c
- * Copyright 1984-2017 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.
- */
-
-#include "system.h"
-#include "sort.h"
-
-#include
-#include