tmtt/chez-openbsd
Archived
1
0
Fork 0
Code Issues Pull requests Releases 1 Activity

fix: README -> README.md

Browse source
This commit is contained in:
tmtt 2022-08-09 23:28:25 +02:00
parent 43e68af625
commit 99b0a6292c
756 changed files with 323753 additions and 71 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

13
README
View file

@ -1,13 +0,0 @@
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.

71
README.md
View file

@ -1,60 +1,17 @@
[![test](https://github.com/cisco/ChezScheme/actions/workflows/test.yml/badge.svg?branch=main)](https://github.com/cisco/ChezScheme/actions/workflows/test.yml)
# chez-openbsd - mirror of ChezScheme with OpenBSD boot files
## ChezScheme v9.5.9
Chez Scheme is both a programming language and an implementation
of that language, with supporting tools and documentation.
**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`.
As a superset of the language described in the
[Revised<sup>6</sup> 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.
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.
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/).
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.

60
README.original.md Normal file
View file

@ -0,0 +1,60 @@
[![test](https://github.com/cisco/ChezScheme/actions/workflows/test.yml/badge.svg?branch=main)](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
[Revised<sup>6</sup> 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/).

1
csug/canned/csug.css
View file

@ -1 +0,0 @@
../csug.css

35
csug/canned/csug.css Normal file
View file

@ -0,0 +1,35 @@
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}

2341
ta6ob/LOG Normal file
View file

File diff suppressed because it is too large Load diff

70
ta6ob/Makefile Normal file
View file

@ -0,0 +1,70 @@
# 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

28
ta6ob/Mf-boot Normal file
View file

@ -0,0 +1,28 @@
# 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-$*

164
ta6ob/Mf-install Normal file
View file

@ -0,0 +1,164 @@
# 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}

BIN
ta6ob/bin/petite Executable file
View file

Binary file not shown.

BIN
ta6ob/bin/scheme Executable file
View file

Binary file not shown.

BIN
ta6ob/bin/ta6ob/petite Executable file
View file

Binary file not shown.

BIN
ta6ob/bin/ta6ob/scheme Executable file
View file

Binary file not shown.

86
ta6ob/bintar/Makefile Normal file
View file

@ -0,0 +1,86 @@
# 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)

993
ta6ob/boot/ta6ob/equates.h Normal file
View file

@ -0,0 +1,993 @@
/* 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

BIN
ta6ob/boot/ta6ob/kernel.o Normal file
View file

Binary file not shown.

BIN
ta6ob/boot/ta6ob/main.o Normal file
View file

Binary file not shown.

BIN
ta6ob/boot/ta6ob/petite.boot Normal file
View file

Binary file not shown.

2
ta6ob/boot/ta6ob/revision Normal file
View file

@ -0,0 +1,2 @@
43e68af625b650124dc0a2c2f22fac26a3449c24
git

BIN
ta6ob/boot/ta6ob/scheme.boot Normal file
View file

Binary file not shown.

245
ta6ob/boot/ta6ob/scheme.h Normal file
View file

@ -0,0 +1,245 @@
/* 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")

47
ta6ob/c/Makefile Normal file
View file

@ -0,0 +1,47 @@
# 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)

82
ta6ob/c/Mf-base Normal file
View file

@ -0,0 +1,82 @@
# 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

22
ta6ob/c/Mf-config Normal file
View file

@ -0,0 +1,22 @@
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}

47
ta6ob/c/Mf-ta6ob Normal file
View file

@ -0,0 +1,47 @@
# 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)

862
ta6ob/c/alloc.c Normal file
View file

@ -0,0 +1,862 @@
/* 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;
}

BIN
ta6ob/c/alloc.o Normal file
View file

Binary file not shown.

672
ta6ob/c/compress-io.c Normal file
View file

@ -0,0 +1,672 @@
/* 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 <fcntl.h>
#include <errno.h>
#ifdef WIN32
#include <io.h>
# 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));
}
}

26
ta6ob/c/compress-io.h Normal file
View file

@ -0,0 +1,26 @@
/* 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;

BIN
ta6ob/c/compress-io.o Normal file
View file

Binary file not shown.

4
ta6ob/c/config.h Normal file
View file

@ -0,0 +1,4 @@
#define SCHEME_SCRIPT "scheme-script"
#ifndef WIN32
#define DEFAULT_HEAP_PATH "/usr/local/lib/csv%v/%m"
#endif

1087
ta6ob/c/expeditor.c Normal file
View file

File diff suppressed because it is too large Load diff

BIN
ta6ob/c/expeditor.o Normal file
View file

Binary file not shown.

415
ta6ob/c/externs.h Normal file
View file

@ -0,0 +1,415 @@
/* 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 <stdlib.h>
#include <string.h>
#include <errno.h>
#include <time.h>
#ifndef WIN32
#include <unistd.h>
#if (machine_type == machine_type_i3qnx || machine_type == machine_type_ti3qnx)
off64_t lseek64(int,off64_t,int);
#endif
#endif
#ifdef SOLARIS
#include <fcntl.h>
#include <sys/wait.h>
#include <setjmp.h>
#endif
#ifdef WIN32
#include <fcntl.h>
#include <direct.h> /* for _getcwd */
#include <setjmp.h>
#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 <math.h>
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);

1662
ta6ob/c/fasl.c Normal file
View file

File diff suppressed because it is too large Load diff

BIN
ta6ob/c/fasl.o Normal file
View file

Binary file not shown.

87
ta6ob/c/flushcache.c Normal file
View file

@ -0,0 +1,87 @@
/* 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 */

BIN
ta6ob/c/flushcache.o Normal file
View file

Binary file not shown.

334
ta6ob/c/foreign.c Normal file
View file

@ -0,0 +1,334 @@
/* 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 <dl.h>
#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 <dlfcn.h>
#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 */
}

BIN
ta6ob/c/foreign.o Normal file
View file

Binary file not shown.

23
ta6ob/c/gc-011.c Normal file
View file

@ -0,0 +1,23 @@
/* 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"

BIN
ta6ob/c/gc-011.o Normal file
View file

Binary file not shown.

18
ta6ob/c/gc-ocd.c Normal file
View file

@ -0,0 +1,18 @@
/* 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"

BIN
ta6ob/c/gc-ocd.o Normal file
View file

Binary file not shown.

19
ta6ob/c/gc-oce.c Normal file
View file

@ -0,0 +1,19 @@
/* 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"

BIN
ta6ob/c/gc-oce.o Normal file
View file

Binary file not shown.

2324
ta6ob/c/gc.c Normal file
View file

File diff suppressed because it is too large Load diff

864
ta6ob/c/gcwrapper.c Normal file
View file

@ -0,0 +1,864 @@
/* 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);
}

BIN
ta6ob/c/gcwrapper.o Normal file
View file

Binary file not shown.

156
ta6ob/c/globals.h Normal file
View file

@ -0,0 +1,156 @@
/* 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<<segment_t3_bits];
#else
EXTERN t1table *S_segment_info[1<<segment_t2_bits];
#endif
#else
EXTERN seginfo *S_segment_info[1<<segment_t1_bits];
#endif
EXTERN chunkinfo *S_chunks_full;
EXTERN chunkinfo *S_chunks[PARTIAL_CHUNK_POOLS+1];
/* schsig.c */
EXTERN IBOOL S_pants_down;
/* foreign.c */
#ifdef LOAD_SHARED_OBJECT
EXTERN ptr S_foreign_dynamic;
#endif
/* globals that do need to be preserved in a saved heap */
EXTERN struct S_G_struct {
/* scheme.c */
double thread_context[size_tc / sizeof(double)];
ptr active_threads_id;
ptr error_invoke_code_object;
ptr invoke_code_object;
ptr dummy_code_object;
ptr heap_reserve_ratio_id;
IBOOL retain_static_relocation;
IBOOL enable_object_counts;
ptr scheme_version_id;
ptr make_load_binary_id;
ptr load_binary;
ptr profile_counters;
/* foreign.c */
ptr foreign_static;
ptr foreign_names;
/* thread.c */
ptr threadno;
/* segment.c */
seginfo *occupied_segments[static_generation+1][max_real_space+1];
uptr number_of_nonstatic_segments;
uptr number_of_empty_segments;
/* alloc.c */
ptr *protected[max_protected];
uptr protect_next;
ptr first_loc[static_generation+1][max_real_space+1];
ptr base_loc[static_generation+1][max_real_space+1];
ptr next_loc[static_generation+1][max_real_space+1];
iptr bytes_left[static_generation+1][max_real_space+1];
uptr bytes_of_space[static_generation+1][max_real_space+1];
uptr bytes_of_generation[static_generation+1];
uptr g0_bytes_after_last_gc;
uptr collect_trip_bytes;
ptr nonprocedure_code;
ptr null_string;
ptr null_vector;
ptr null_fxvector;
ptr null_bytevector;
seginfo *dirty_segments[DIRTY_SEGMENT_LISTS];
/* schsig.c */
ptr error_id;
ptr nuate_id;
ptr null_continuation_id;
ptr collect_request_pending_id;
/* gc.c */
ptr guardians[static_generation+1];
ptr locked_objects[static_generation+1];
ptr unlocked_objects[static_generation+1];
IGEN min_free_gen;
IGEN new_min_free_gen;
IGEN max_nonstatic_generation;
IGEN new_max_nonstatic_generation;
uptr countof[static_generation+1][countof_types];
uptr bytesof[static_generation+1][countof_types];
uptr gctimestamp[static_generation+1];
ptr rtds_with_counts[static_generation+1];
uptr countof_size[countof_types];
ptr static_id;
ptr countof_names;
IGEN prcgeneration;
/* intern.c */
iptr *oblist_length_pointer;
iptr oblist_length;
iptr oblist_count;
bucket **oblist;
bucket_list *buckets_of_generation[static_generation];
/* prim.c */
ptr library_entry_vector;
ptr c_entry_vector;
/* fasl.c */
ptr base_rtd;
ptr rtd_key;
ptr eq_symbol;
ptr eq_ht_rtd;
ptr symbol_symbol;
ptr symbol_ht_rtd;
ptr eqp;
ptr eqvp;
ptr equalp;
ptr symboleqp;
} S_G;

26
ta6ob/c/i3le.c Normal file
View file

@ -0,0 +1,26 @@
/* i3le.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 <sys/types.h>
#include <sys/mman.h>
#ifdef FLUSHCACHE
oops, no S_flushcache_max_gap or S_doflush
#endif /* FLUSHCACHE */
void S_machine_init(void) {}

BIN
ta6ob/c/i3le.o Normal file
View file

Binary file not shown.

389
ta6ob/c/intern.c Normal file
View file

@ -0,0 +1,389 @@
/* 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);
}
}

BIN
ta6ob/c/intern.o Normal file
View file

Binary file not shown.

277
ta6ob/c/io.c Normal file
View file

@ -0,0 +1,277 @@
/* 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 <sys/types.h>
#include <sys/stat.h>
#include <limits.h>
#ifdef WIN32
#include <io.h>
#include <shlobj.h>
#pragma comment(lib, "shell32.lib")
#else /* WIN32 */
#include <sys/file.h>
#include <dirent.h>
#include <pwd.h>
#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 */

BIN
ta6ob/c/io.o Normal file
View file

Binary file not shown.

247
ta6ob/c/itest.c Normal file
View file

@ -0,0 +1,247 @@
/* 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');
}
}

376
ta6ob/c/main.c Normal file
View file

@ -0,0 +1,376 @@
/* 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 <stdlib.h>
#include <string.h>
#include <stdio.h>
#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 <path> run as shell script\n");
fprintf(stderr," --program <path> run rnrs program as shell script\n");
#ifdef WIN32
#define sep ";"
#else
#define sep ":"
#endif
fprintf(stderr," --libdirs <dir>%s... set library directories\n", sep);
fprintf(stderr," --libexts <ext>%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 <off | path> 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 <path>, --boot <path> load boot file\n");
// fprintf(stderr," -c, --compact toggle compaction flag\n");
// fprintf(stderr," -h <path>, --heap <path> load heap file\n");
// fprintf(stderr," -s[<n>] <path>, --saveheap[<n>] <path> 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 <name>.boot, where <name> 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);
}

BIN
ta6ob/c/main.o Normal file
View file

Binary file not shown.

970
ta6ob/c/new-io.c Normal file
View file

@ -0,0 +1,970 @@
/* 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 <sys/types.h>
#include <sys/stat.h>
#include <limits.h>
#ifdef WIN32
#include <io.h>
#else /* WIN32 */
#include <sys/file.h>
#include <dirent.h>
#include <pwd.h>
#endif /* WIN32 */
#include <fcntl.h>
#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);
}