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:
Tom MTT. 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 **THIS REPO IS A MIRROR OF [CHEZSCHEME](https://github.com/cisco/ChezScheme) CONTAINING OPENBSD BOOT FILES.**
of that language, with supporting tools and documentation. 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 To build on OpenBSD, simply do:
[Revised<sup>6</sup> Report on the Algorithmic Language Scheme](http://www.r6rs.org) ```bash
(R6RS), Chez Scheme supports all standard features of Scheme, $ ./configure --threads
including first-class procedures, proper treatment of tail calls, $ gmake -jN
continuations, user-defined records, libraries, exceptions, and ```
hygienic macro expansion. `--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 See [releases](https://basedwa.re/tmtt/chez-openbsd/releases).
and other languages, support for multiple threads possibly running See [the original blogpost](https://heimdall.pm/blog/2022/07/28/how-to-build-chezscheme-on-openbsd.html) for more information.
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/).

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);
}
if (saved_errno == EAGAIN) {
return FIX(0);
}
if (gzflag && saved_errno == 0) {
return Sstring("compression failed");
}
return S_strerror(saved_errno);
}
ptr S_get_fd_pos(ptr file, IBOOL gzflag) {
errno = 0;
if (gzflag) {
z_off_t offset = S_glzseek(GZXFILE_GZFILE(file), 0, SEEK_CUR);
if (offset != -1) return Sinteger64(offset);
} else {
OFF_T offset = LSEEK(GET_FD(file), 0, SEEK_CUR);
if (offset != -1) return Sinteger64(offset);
}
if (gzflag && errno == 0) return Sstring("compression failed");
return S_strerror(errno);
}
/* assume wrapper ensures 0 <= pos <= 2^63-1 */
ptr S_set_fd_pos(ptr file, ptr pos, IBOOL gzflag) {
I64 offset64 = S_int64_value("set-file-position", pos);
if (gzflag) {
z_off_t offset = (z_off_t)offset64;
if (sizeof(z_off_t) != sizeof(I64))
if (offset != offset64) return Sstring("invalid position");
errno = 0;
if (S_glzseek(GZXFILE_GZFILE(file),offset,SEEK_SET) == offset) return Strue;
if (errno == 0) return Sstring("compression failed");
return S_strerror(errno);
} else {
OFF_T offset = (OFF_T)offset64;
if (sizeof(OFF_T) != sizeof(I64))
if (offset != offset64) return Sstring("invalid position");
if (LSEEK(GET_FD(file), offset, SEEK_SET) == offset) return Strue;
return S_strerror(errno);
}
}
ptr S_get_fd_non_blocking(ptr file, IBOOL gzflag) {
#ifdef WIN32
return Sfalse;
#else /* WIN32 */
INT fcntl_flags;
if (gzflag) return Sfalse;
fcntl_flags = fcntl(GET_FD(file), F_GETFL, 0);
if (fcntl_flags == -1) {
return S_strerror(errno);
}
return Sboolean(NOBLOCK & fcntl_flags);
#endif /* WIN32 */
}
ptr S_set_fd_non_blocking(ptr file, IBOOL x, IBOOL gzflag) {
#ifdef WIN32
return Sstring("unsupported");
#else /* WIN32 */
iptr fd;
INT fcntl_flags;
if (gzflag) {
if (x) return Sstring("Compressed non-blocking ports not supported");
else return Strue;
}
fd = GET_FD(file);
fcntl_flags = fcntl(fd, F_GETFL, 0);
if (fcntl_flags == -1) {
return S_strerror(errno);
}
if (x) {
if (fcntl_flags & NOBLOCK) {
return Strue;
}
if (0 == fcntl(fd, F_SETFL, fcntl_flags | NOBLOCK)) {
return Strue;
}
return S_strerror(errno);
} else {
if (!(fcntl_flags & NOBLOCK)) {
return Strue;
}
if (0 == fcntl(fd, F_SETFL, fcntl_flags & ~NOBLOCK)) {
return Strue;
}
return S_strerror(errno);
}
#endif /* WIN32 */
}
ptr S_get_fd_length(ptr file, IBOOL gzflag) {
struct STATBUF statbuf;
if (gzflag) return Sstring("Not supported on compressed files");
if (FSTAT(GET_FD(file), &statbuf) == 0) {
return Sinteger64(statbuf.st_size);
}
return S_strerror(errno);
}
ptr S_set_fd_length(ptr file, ptr length, IBOOL gzflag) {
INT fd, ok, flag = 0;
I64 len64; off_t len;
#ifdef PTHREADS
ptr tc = get_thread_context();
#endif
if (gzflag) return Sstring("Not supported on compressed files");
len64 = S_int64_value("set-file-length", length);
len = (off_t)len64;
if (sizeof(off_t) != sizeof(I64))
if (len != len64) return Sstring("invalid length");
fd = GET_FD(file);
DEACTIVATE(tc)
FD_EINTR_GUARD(ok == 0, flag, ok = ftruncate(fd, len));
REACTIVATE(tc)
return flag ? S_strerror(errno) : Strue;
}
void S_new_io_init(void) {
if (S_boot_time) {
S_set_symbol_value(S_intern((const unsigned char *)"$c-bufsiz"), Sinteger(SBUFSIZ));
}
#ifdef WIN32
{ /* Get the console input handle for reading Unicode characters */
HANDLE h;
DWORD mode;
if ((h = GetStdHandle(STD_INPUT_HANDLE)) != INVALID_HANDLE_VALUE
&& GetConsoleMode(h, &mode))
hStdin = h;
}
/* transcoder, if any, does its own cr, lf translations */
_setmode(_fileno(stdin), O_BINARY);
_setmode(_fileno(stdout), O_BINARY);
_setmode(_fileno(stderr), O_BINARY);
/* Set the console output to handle UTF-8 */
SetConsoleOutputCP(CP_UTF8);
#endif /* WIN32 */
}
static int is_valid_zlib_length(iptr count) {
/* A zlib `uLong` may be the same as `unsigned long`,
which is not as big as `iptr` on 64-bit Windows. */
return count == (iptr)(uLong)count;
}
static int is_valid_lz4_length(iptr len) {
return (len <= LZ4_MAX_INPUT_SIZE);
}
/* Accept `iptr` because we expect it to represent a bytevector size,
which always fits in `iptr`. Return `uptr`, because the result might
not fit in `iptr`. */
uptr S_bytevector_compress_size(iptr s_count, INT compress_format) {
switch (compress_format) {
case COMPRESS_GZIP:
if (is_valid_zlib_length(s_count))
return compressBound((uLong)s_count);
else {
/* Compression will report "source too long" */
return 0;
}
case COMPRESS_LZ4:
if (is_valid_lz4_length(s_count))
return LZ4_compressBound((uLong)s_count);
else {
/* Compression will report "source too long" */
return 0;
}
default:
S_error1("S_bytevector_compress_size", "unexpected compress format ~s", FIX(compress_format));
return 0;
}
}
ptr S_bytevector_compress(ptr dest_bv, iptr d_start, iptr d_count,
ptr src_bv, iptr s_start, iptr s_count,
INT compress_format) {
ptr tc = get_thread_context();
int compress_level = (INT)UNFIX(COMPRESSLEVEL(tc));
/* On error, an message-template string with ~s for the bytevector */
switch (compress_format) {
case COMPRESS_GZIP:
{
int r;
uLong destLen;
if (!is_valid_zlib_length(s_count))
return Sstring("source bytevector ~s is too large");
destLen = (uLong)d_count;
r = compress2(&BVIT(dest_bv, d_start), &destLen, &BVIT(src_bv, s_start), (uLong)s_count, S_zlib_compress_level(compress_level));
if (r == Z_OK)
return FIX(destLen);
else if (r == Z_BUF_ERROR)
return Sstring("destination bytevector is too small for compressed form of ~s");
else
return Sstring("internal error compressing ~s");
}
case COMPRESS_LZ4:
{
int destLen;
if (!is_valid_lz4_length(s_count))
return Sstring("source bytevector ~s is too large");
if (compress_level == COMPRESS_MIN) {
destLen = LZ4_compress_default((char *)&BVIT(src_bv, s_start), (char *)&BVIT(dest_bv, d_start), (int)s_count, (int)d_count);
} else {
destLen = LZ4_compress_HC((char *)&BVIT(src_bv, s_start), (char *)&BVIT(dest_bv, d_start), (int)s_count, (int)d_count, S_lz4_compress_level(compress_level));
}
if (destLen > 0)
return Sfixnum(destLen);
else
return Sstring("compression failed for ~s");
}
default:
S_error1("S_bytevector_compress", "unexpected compress format ~s", FIX(compress_format));
return Sfalse;
}
}
ptr S_bytevector_uncompress(ptr dest_bv, iptr d_start, iptr d_count,
ptr src_bv, iptr s_start, iptr s_count,
INT compress_format) {
/* On error, an message-template string with ~s for the bytevector */
switch (compress_format) {
case COMPRESS_GZIP:
{
int r;
uLongf destLen;
if (!is_valid_zlib_length(d_count))
return Sstring("expected result size of uncompressed source ~s is too large");
destLen = (uLongf)d_count;
r = uncompress(&BVIT(dest_bv, d_start), &destLen, &BVIT(src_bv, s_start), (uLong)s_count);
if (r == Z_OK)
return FIX(destLen);
else if (r == Z_BUF_ERROR)
return Sstring("uncompressed ~s is larger than expected size");
else if (r == Z_DATA_ERROR)
return Sstring("invalid data in source bytevector ~s");
else
return Sstring("internal error uncompressing ~s");
}
case COMPRESS_LZ4:
{
int r;
if (!is_valid_lz4_length(d_count))
return Sstring("expected result size of uncompressed source ~s is too large");
r = LZ4_decompress_safe((char *)&BVIT(src_bv, s_start), (char *)&BVIT(dest_bv, d_start), (int)s_count, (int)d_count);
if (r >= 0)
return Sfixnum(r);
else
return Sstring("internal error uncompressing ~s");
}
default:
return Sstring("unexpected compress format ~s");
}
}

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

Binary file not shown.

24
ta6ob/c/nocurses.h Normal file
View file

@ -0,0 +1,24 @@
#ifndef ERR
# define ERR -1
#endif
#define setupterm(a, b, e) (*(e) = 0, ERR)
#define tputs(c, x, f) (f(c))
#define lines 0
#define columns 0
#define cursor_left 0
#define cursor_right 0
#define cursor_up 0
#define cursor_down 0
#define enter_am_mode 0
#define exit_am_mode 0
#define clr_eos 0
#define clr_eol 0
#define clear_screen 0
#define carriage_return 0
#define bell 0
#define scroll_reverse 0
#define auto_right_margin 0
#define eat_newline_glitch 0

2120
ta6ob/c/number.c Normal file
View file

File diff suppressed because it is too large Load diff

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

Binary file not shown.

288
ta6ob/c/prim.c Normal file
View file

@ -0,0 +1,288 @@
/* prim.c
* Copyright 1984-2017 Cisco Systems, Inc.
*
* Licensed under the Apache License, Version 2.0 (the "License");
* you may not use this file except in compliance with the License.
* You may obtain a copy of the License at
*
* http://www.apache.org/licenses/LICENSE-2.0
*
* Unless required by applicable law or agreed to in writing, software
* distributed under the License is distributed on an "AS IS" BASIS,
* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
* See the License for the specific language governing permissions and
* limitations under the License.
*/
#include "system.h"
/* locally defined functions */
static void install_library_entry(ptr n, ptr x);
static void scheme_install_library_entry(void);
static void create_library_entry_vector(void);
static void install_c_entry(iptr i, ptr x);
static void create_c_entry_vector(void);
static void s_instantiate_code_object(void);
static void s_link_code_object(ptr co, ptr objs);
static IBOOL s_check_heap_enabledp(void);
static void s_enable_check_heap(IBOOL b);
static uptr s_check_heap_errors(void);
static void install_library_entry(ptr n, ptr x) {
if (!Sfixnump(n) || UNFIX(n) < 0 || UNFIX(n) >= library_entry_vector_size)
S_error1("$install-library-entry", "invalid index ~s", n);
if (!Sprocedurep(x) && !Scodep(x))
S_error2("$install-library-entry", "invalid entry ~s for ~s", x, n);
if (Svector_ref(S_G.library_entry_vector, UNFIX(n)) != Sfalse) {
printf("$install-library-entry: overwriting entry for %ld\n", (long)UNFIX(n));
fflush(stdout);
}
SETVECTIT(S_G.library_entry_vector, UNFIX(n), x);
if (n == FIX(library_nonprocedure_code)) {
S_G.nonprocedure_code = x;
S_retrofit_nonprocedure_code();
}
}
ptr S_lookup_library_entry(iptr n, IBOOL errorp) {
ptr p;
if (n < 0 || n >= library_entry_vector_size)
S_error1("$lookup-library-entry", "invalid index ~s", FIX(n));
p = Svector_ref(S_G.library_entry_vector, n);
if (p == Sfalse && errorp)
S_error1("$lookup-library-entry", "entry ~s uninitialized", FIX(n));
return p;
}
static void scheme_install_library_entry(void) {
ptr tc = get_thread_context();
install_library_entry(S_get_scheme_arg(tc, 1), S_get_scheme_arg(tc, 2));
}
static void create_library_entry_vector(void) {
iptr i;
S_protect(&S_G.library_entry_vector);
S_G.library_entry_vector = S_vector(library_entry_vector_size);
for (i = 0; i < library_entry_vector_size; i++)
INITVECTIT(S_G.library_entry_vector, i) = Sfalse;
}
#ifdef HPUX
#define proc2ptr(x) int2ptr((iptr)(x))
ptr int2ptr(iptr f)
{
if ((f & 2) == 0)
S_error("proc2ptr", "invalid C procedure");
return (ptr)(f & ~0x3);
}
#else /* HPUX */
#define proc2ptr(x) (ptr)(iptr)(x)
#endif /* HPUX */
static void install_c_entry(iptr i, ptr x) {
if (i < 0 || i >= c_entry_vector_size)
S_error1("install_c_entry", "invalid index ~s", FIX(i));
if (Svector_ref(S_G.c_entry_vector, i) != Sfalse)
S_error1("install_c_entry", "duplicate entry for ~s", FIX(i));
SETVECTIT(S_G.c_entry_vector, i, x);
}
ptr S_lookup_c_entry(iptr i) {
ptr x;
if (i < 0 || i >= c_entry_vector_size)
S_error1("lookup_c_entry", "invalid index ~s", FIX(i));
if ((x = Svector_ref(S_G.c_entry_vector, i)) == Sfalse)
S_error1("lookup_c_entry", "uninitialized entry ~s", FIX(i));
return x;
}
static ptr s_get_thread_context(void) {
return get_thread_context();
}
static void create_c_entry_vector(void) {
INT i;
S_protect(&S_G.c_entry_vector);
S_G.c_entry_vector = S_vector(c_entry_vector_size);
for (i = 0; i < c_entry_vector_size; i++)
INITVECTIT(S_G.c_entry_vector, i) = Sfalse;
install_c_entry(CENTRY_thread_context, proc2ptr(S_G.thread_context));
install_c_entry(CENTRY_get_thread_context, proc2ptr(s_get_thread_context));
install_c_entry(CENTRY_handle_apply_overflood, proc2ptr(S_handle_apply_overflood));
install_c_entry(CENTRY_handle_docall_error, proc2ptr(S_handle_docall_error));
install_c_entry(CENTRY_handle_overflow, proc2ptr(S_handle_overflow));
install_c_entry(CENTRY_handle_overflood, proc2ptr(S_handle_overflood));
install_c_entry(CENTRY_handle_nonprocedure_symbol, proc2ptr(S_handle_nonprocedure_symbol));
install_c_entry(CENTRY_thread_list, (ptr)&S_threads);
install_c_entry(CENTRY_split_and_resize, proc2ptr(S_split_and_resize));
#ifdef PTHREADS
install_c_entry(CENTRY_raw_collect_cond, (ptr)&S_collect_cond);
install_c_entry(CENTRY_raw_tc_mutex, (ptr)&S_tc_mutex);
install_c_entry(CENTRY_activate_thread, proc2ptr(S_activate_thread));
install_c_entry(CENTRY_deactivate_thread, proc2ptr(Sdeactivate_thread));
install_c_entry(CENTRY_unactivate_thread, proc2ptr(S_unactivate_thread));
#endif /* PTHREADS */
install_c_entry(CENTRY_handle_values_error, proc2ptr(S_handle_values_error));
install_c_entry(CENTRY_handle_mvlet_error, proc2ptr(S_handle_mvlet_error));
install_c_entry(CENTRY_handle_arg_error, proc2ptr(S_handle_arg_error));
install_c_entry(CENTRY_foreign_entry, proc2ptr(S_foreign_entry));
install_c_entry(CENTRY_install_library_entry, proc2ptr(scheme_install_library_entry));
install_c_entry(CENTRY_get_more_room, proc2ptr(S_get_more_room));
install_c_entry(CENTRY_scan_remembered_set, proc2ptr(S_scan_remembered_set));
install_c_entry(CENTRY_instantiate_code_object, proc2ptr(s_instantiate_code_object));
install_c_entry(CENTRY_Sreturn, proc2ptr(S_return));
install_c_entry(CENTRY_Scall_one_result, proc2ptr(S_call_one_result));
install_c_entry(CENTRY_Scall_any_results, proc2ptr(S_call_any_results));
for (i = 0; i < c_entry_vector_size; i++) {
#ifndef PTHREADS
if (i == CENTRY_raw_collect_cond || i == CENTRY_raw_tc_mutex
|| i == CENTRY_activate_thread || i == CENTRY_deactivate_thread
|| i == CENTRY_unactivate_thread)
continue;
#endif /* NOT PTHREADS */
if (Svector_ref(S_G.c_entry_vector, i) == Sfalse) {
fprintf(stderr, "c_entry_vector entry %d is uninitialized\n", i);
S_abnormal_exit();
}
}
}
void S_prim_init(void) {
if (!S_boot_time) return;
create_library_entry_vector();
create_c_entry_vector();
Sforeign_symbol("(cs)fixedpathp", (void *)S_fixedpathp);
Sforeign_symbol("(cs)bytes_allocated", (void *)S_compute_bytes_allocated);
Sforeign_symbol("(cs)curmembytes", (void *)S_curmembytes);
Sforeign_symbol("(cs)maxmembytes", (void *)S_maxmembytes);
Sforeign_symbol("(cs)resetmaxmembytes", (void *)S_resetmaxmembytes);
Sforeign_symbol("(cs)do_gc", (void *)S_do_gc);
Sforeign_symbol("(cs)check_heap_enabledp", (void *)s_check_heap_enabledp);
Sforeign_symbol("(cs)enable_check_heap", (void *)s_enable_check_heap);
Sforeign_symbol("(cs)check_heap_errors", (void *)s_check_heap_errors);
Sforeign_symbol("(cs)lookup_library_entry", (void *)S_lookup_library_entry);
Sforeign_symbol("(cs)link_code_object", (void *)s_link_code_object);
Sforeign_symbol("(cs)lookup_c_entry", (void *)S_lookup_c_entry);
Sforeign_symbol("(cs)lock_object", (void *)Slock_object);
Sforeign_symbol("(cs)unlock_object", (void *)Sunlock_object);
Sforeign_symbol("(cs)locked_objectp", (void *)Slocked_objectp);
Sforeign_symbol("(cs)locked_objects", (void *)S_locked_objects);
Sforeign_symbol("(cs)maxgen", (void *)S_maxgen);
Sforeign_symbol("(cs)set_maxgen", (void *)S_set_maxgen);
Sforeign_symbol("(cs)minfreegen", (void *)S_minfreegen);
Sforeign_symbol("(cs)set_minfreegen", (void *)S_set_minfreegen);
Sforeign_symbol("(cs)enable_object_counts", (void *)S_enable_object_counts);
Sforeign_symbol("(cs)set_enable_object_counts", (void *)S_set_enable_object_counts);
Sforeign_symbol("(cs)object_counts", (void *)S_object_counts);
Sforeign_symbol("(cs)unregister_guardian", (void *)S_unregister_guardian);
Sforeign_symbol("(cs)fire_collector", (void *)S_fire_collector);
}
static void s_instantiate_code_object(void) {
ptr tc = get_thread_context();
ptr old, cookie, proc;
ptr new, oldreloc, newreloc;
ptr pinfos;
uptr a, m, n;
iptr i, size;
old = S_get_scheme_arg(tc, 1);
cookie = S_get_scheme_arg(tc, 2);
proc = S_get_scheme_arg(tc, 3);
tc_mutex_acquire()
new = S_code(tc, CODETYPE(old), CODELEN(old));
tc_mutex_release()
oldreloc = CODERELOC(old);
size = RELOCSIZE(oldreloc);
newreloc = S_relocation_table(size);
RELOCCODE(newreloc) = new;
for (i = 0; i < size; i += 1) RELOCIT(newreloc, i) = RELOCIT(oldreloc, i);
CODERELOC(new) = newreloc;
CODENAME(new) = CODENAME(old);
CODEARITYMASK(new) = CODEARITYMASK(old);
CODEFREE(new) = CODEFREE(old);
CODEINFO(new) = CODEINFO(old);
CODEPINFOS(new) = pinfos = CODEPINFOS(old);
if (pinfos != Snil) {
S_G.profile_counters = Scons(S_weak_cons(new, pinfos), S_G.profile_counters);
}
for (i = 0; i < CODELEN(old); i++) CODEIT(new,i) = CODEIT(old,i);
m = RELOCSIZE(newreloc);
a = 0;
n = 0;
while (n < m) {
uptr entry, item_off, code_off; ptr obj;
entry = RELOCIT(newreloc, n); n += 1;
if (RELOC_EXTENDED_FORMAT(entry)) {
item_off = RELOCIT(newreloc, n); n += 1;
code_off = RELOCIT(newreloc, n); n += 1;
} else {
item_off = RELOC_ITEM_OFFSET(entry);
code_off = RELOC_CODE_OFFSET(entry);
}
a += code_off;
obj = S_get_code_obj(RELOC_TYPE(entry), old, a, item_off);
/* we've seen the enemy, and he is us */
if (obj == old) obj = new;
/* if we find our cookie, insert proc; otherwise, insert the object
into new to get proper adjustment of relative addresses */
if (obj == cookie)
S_set_code_obj("fcallable", RELOC_TYPE(entry), new, a, proc, item_off);
else
S_set_code_obj("fcallable", RELOC_TYPE(entry), new, a, obj, item_off);
}
S_flush_instruction_cache(tc);
AC0(tc) = new;
}
static void s_link_code_object(ptr co, ptr objs) {
ptr t; uptr a, m, n;
t = CODERELOC(co);
m = RELOCSIZE(t);
a = 0;
n = 0;
while (n < m) {
uptr entry, item_off, code_off;
entry = RELOCIT(t, n); n += 1;
if (RELOC_EXTENDED_FORMAT(entry)) {
item_off = RELOCIT(t, n); n += 1;
code_off = RELOCIT(t, n); n += 1;
} else {
item_off = RELOC_ITEM_OFFSET(entry);
code_off = RELOC_CODE_OFFSET(entry);
}
a += code_off;
S_set_code_obj("gc", RELOC_TYPE(entry), co, a, Scar(objs), item_off);
objs = Scdr(objs);
}
}
static INT s_check_heap_enabledp(void) {
return S_checkheap;
}
static void s_enable_check_heap(IBOOL b) {
S_checkheap = b;
}
static uptr s_check_heap_errors(void) {
return S_checkheap_errors;
}

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

Binary file not shown.

2052
ta6ob/c/prim5.c Normal file
View file

File diff suppressed because it is too large Load diff

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

Binary file not shown.

288
ta6ob/c/print.c Normal file
View file

@ -0,0 +1,288 @@
/* print.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 pimmediate(ptr x);
static void pbox(ptr x);
static void pclo(ptr x);
static void pcode(ptr x);
static void pcons(ptr x);
static void pfile(ptr x);
static void pinexactnum(ptr x);
static IBOOL exact_real_negativep(ptr x);
static void pexactnum(ptr x);
static void prat(ptr x);
static void pchar(ptr x);
static void pstr(ptr x);
static void psym(ptr x);
static void pvec(ptr x);
static void pfxvector(ptr x);
static void pbytevector(ptr x);
static void pflonum(ptr x);
static void pfixnum(ptr x);
static void pbignum(ptr x);
static void wrint(ptr x);
void S_print_init(void) {}
void S_prin1(ptr x) {
if (Simmediatep(x)) pimmediate(x);
else if (Spairp(x)) pcons(x);
else if (Ssymbolp(x)) psym(x);
else if (Sfixnump(x)) pfixnum(x);
else if (Sbignump(x)) pbignum(x);
else if (Sstringp(x)) pstr(x);
else if (Sratnump(x)) prat(x);
else if (Sflonump(x)) (void) pflonum(x);
else if (Sinexactnump(x)) pinexactnum(x);
else if (Sexactnump(x)) pexactnum(x);
else if (Svectorp(x)) pvec(x);
else if (Sfxvectorp(x)) pfxvector(x);
else if (Sbytevectorp(x)) pbytevector(x);
else if (Sboxp(x)) pbox(x);
else if (Sprocedurep(x)) pclo(x);
else if (Scodep(x)) pcode(x);
else if (Sportp(x)) pfile(x);
else if (Srecordp(x)) printf("#<record>");
else printf("#<garbage>");
fflush(stdout);
}
static void pimmediate(ptr x) {
if (Scharp(x)) pchar(x);
else if (x == Snil) printf("()");
else if (x == Strue) printf("#t");
else if (x == Sfalse) printf("#f");
else if (x == Seof_object) printf("#!eof");
else if (x == Sbwp_object) printf("#!bwp");
else if (x == sunbound) printf("#<unbound>");
else if (x == Svoid) printf("#<void>");
else printf("#<garbage>");
}
static void pbox(ptr x) {
printf("#&");
S_prin1(Sunbox(x));
}
static void pclo(UNUSED ptr x) {
if (CODETYPE(CLOSCODE(x)) & (code_flag_continuation << code_flags_offset))
printf("#<continuation>");
else
printf("#<procedure>");
}
static void pcode(UNUSED ptr x) {
printf("#<code>");
}
static void pcons(ptr x) {
putchar('(');
while (1) {
S_prin1(Scar(x));
x = Scdr(x);
if (!Spairp(x)) break;
putchar(' ');
}
if (x!=Snil) {
printf(" . ");
S_prin1(x);
}
putchar(')');
}
static void pfile(UNUSED ptr x) {
printf("#<port>");
}
static void pinexactnum(ptr x) {
S_prin1(TYPE(&INEXACTNUM_REAL_PART(x),type_flonum));
if (INEXACTNUM_IMAG_PART(x) >= 0.0) putchar('+');
S_prin1(TYPE(&INEXACTNUM_IMAG_PART(x),type_flonum));
putchar('i');
}
static IBOOL exact_real_negativep(ptr x) {
if (Sratnump(x)) x = RATNUM(x);
return Sfixnump(x) ? UNFIX(x) < 0 : BIGSIGN(x);
}
static void pexactnum(ptr x) {
S_prin1(EXACTNUM_REAL_PART(x));
if (!exact_real_negativep(EXACTNUM_IMAG_PART(x))) putchar('+');
S_prin1(EXACTNUM_IMAG_PART(x));
putchar('i');
}
static void prat(ptr x) {
wrint(RATNUM(x));
putchar('/');
wrint(RATDEN(x));
}
static void pchar(ptr x) {
int k = Schar_value(x);
if (k >= 256) k = '?';
printf("#\\");
putchar(k);
}
static void pstr(ptr x) {
iptr i, n = Sstring_length(x);
putchar('"');
for (i = 0; i < n; i += 1) {
int k = Sstring_ref(x, i);
if (k >= 256) k = '?';
if ((k == '\\') || (k == '"')) putchar('\\');
putchar(k);
}
putchar('"');
}
static void display_string(ptr x) {
iptr i, n = Sstring_length(x);
for (i = 0; i < n; i += 1) {
int k = Sstring_ref(x, i);
if (k >= 256) k = '?';
putchar(k);
}
}
static void psym(ptr x) {
ptr name = SYMNAME(x);
if (Sstringp(name)) {
display_string(name);
} else if (Spairp(name)) {
if (Scar(name) != Sfalse) {
printf("#{");
display_string(Scdr(name));
printf(" ");
display_string(Scar(name));
printf("}");
} else {
printf("#<gensym ");
display_string(Scdr(name));
printf(">");
}
} else {
printf("#<gensym>");
}
}
static void pvec(ptr x) {
iptr n;
putchar('#');
n = Svector_length(x);
wrint(FIX(n));
putchar('(');
if (n != 0) {
iptr i = 0;
while (1) {
S_prin1(Svector_ref(x, i));
if (++i == n) break;
putchar(' ');
}
}
putchar(')');
}
static void pfxvector(ptr x) {
iptr n;
putchar('#');
n = Sfxvector_length(x);
wrint(FIX(n));
printf("vfx(");
if (n != 0) {
iptr i = 0;
while (1) {
pfixnum(Sfxvector_ref(x, i));
if (++i == n) break;
putchar(' ');
}
}
putchar(')');
}
static void pbytevector(ptr x) {
iptr n;
putchar('#');
n = Sbytevector_length(x);
wrint(FIX(n));
printf("vu8(");
if (n != 0) {
iptr i = 0;
while (1) {
pfixnum(FIX(Sbytevector_u8_ref(x, i)));
if (++i == n) break;
putchar(' ');
}
}
putchar(')');
}
static void pflonum(ptr x) {
char buf[256], *s;
/* use snprintf to get it in a string */
(void) snprintf(buf, 256, "%.16g",FLODAT(x));
/* print the silly thing */
printf("%s", buf);
/* add .0 if it looks like an integer */
s = buf;
while (*s != 'E' && *s != 'e' && *s != '.')
if (*s++ == 0) {
printf(".0");
break;
}
}
static void pfixnum(ptr x) {
if (UNFIX(x) < 0) {
putchar('-');
x = S_sub(FIX(0), x);
}
wrint(x);
}
static void pbignum(ptr x) {
if (BIGSIGN(x)) {
putchar('-');
x = S_sub(FIX(0), x);
}
wrint(x);
}
static void wrint(ptr x) {
ptr q, r;
S_trunc_rem(get_thread_context(), x, FIX(10), &q, &r);
if (q != 0) wrint(q);
putchar((INT)UNFIX(r) + '0');
}

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

Binary file not shown.

1273
ta6ob/c/scheme.c Normal file
View file

File diff suppressed because it is too large Load diff

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

Binary file not shown.

307
ta6ob/c/schlib.c Normal file
View file

@ -0,0 +1,307 @@
/* schlib.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 ptr S_call(ptr tc, ptr cp, iptr argcnt);
/* Sinteger_value is in number.c */
/* Sinteger32_value is in number.c */
/* Sinteger64_value is in number.c */
void Sset_box(ptr x, ptr y) {
SETBOXREF(x, y);
}
void Sset_car(ptr x, ptr y) {
SETCAR(x, y);
}
void Sset_cdr(ptr x, ptr y) {
SETCDR(x, y);
}
void Svector_set(ptr x, iptr i, ptr y) {
SETVECTIT(x, i, y);
}
/* Scons is in alloc.c */
ptr Sstring_to_symbol(const char *s) {
return S_intern((const unsigned char *)s);
}
ptr Ssymbol_to_string(ptr x) {
ptr name = SYMNAME(x);
if (Sstringp(name))
return name;
else if (Spairp(name))
return Scdr(name);
else
/* don't have access to prefix or count, and can't handle arbitrary
prefixes anyway, so always punt */
return S_string("gensym", -1);
}
/* Sflonum is in alloc.c */
ptr Smake_vector(iptr n, ptr x) {
ptr p; iptr i;
p = S_vector(n);
for (i = 0; i < n; i += 1) INITVECTIT(p, i) = x;
return p;
}
ptr Smake_fxvector(iptr n, ptr x) {
ptr p; iptr i;
p = S_fxvector(n);
for (i = 0; i < n; i += 1) Sfxvector_set(p, i, x);
return p;
}
ptr Smake_bytevector(iptr n, int x) {
ptr p; iptr i;
p = S_bytevector(n);
for (i = 0; i < n; i += 1) Sbytevector_u8_set(p, i, (octet)x);
return p;
}
ptr Smake_string(iptr n, int c) {
ptr p; iptr i;
p = S_string((char *)NULL, n);
for (i = 0; i < n; i += 1) Sstring_set(p, i, c);
return p;
}
ptr Smake_uninitialized_string(iptr n) {
return S_string((char *)NULL, n);
}
ptr Sstring(const char *s) {
return S_string(s, -1);
}
ptr Sstring_of_length(const char *s, iptr n) {
return S_string(s, n);
}
/* Sstring_utf8 is in alloc.c */
/* Sbox is in alloc.c */
/* Sinteger is in number.c */
/* Sunsigned is in number.c */
/* Sunsigned32 is in number.c */
/* Sunsigned64 is in number.c */
ptr Stop_level_value(ptr x) {
ptr tc = get_thread_context();
IBOOL enabled = (DISABLECOUNT(tc) == 0);
if (enabled) DISABLECOUNT(tc) = FIX(UNFIX(DISABLECOUNT(tc)) + 1);
x = Scall1(S_symbol_value(Sstring_to_symbol("$c-tlv")), x);
if (enabled) DISABLECOUNT(tc) = FIX(UNFIX(DISABLECOUNT(tc)) - 1);
return x;
}
void Sset_top_level_value(ptr x, ptr y) {
ptr tc = get_thread_context();
IBOOL enabled = (DISABLECOUNT(tc) == 0);
if (enabled) DISABLECOUNT(tc) = FIX(UNFIX(DISABLECOUNT(tc)) + 1);
Scall2(S_symbol_value(Sstring_to_symbol("$c-stlv!")), x, y);
if (enabled) DISABLECOUNT(tc) = FIX(UNFIX(DISABLECOUNT(tc)) - 1);
}
#include <setjmp.h>
/* consider rewriting these to avoid multiple calls to get_thread_context */
ptr Scall0(ptr cp) {
ptr tc = get_thread_context();
S_initframe(tc,0);
return S_call(tc, cp, 0);
}
ptr Scall1(ptr cp, ptr x1) {
ptr tc = get_thread_context();
S_initframe(tc, 1);
S_put_arg(tc, 1, x1);
return S_call(tc, cp, 1);
}
ptr Scall2(ptr cp, ptr x1, ptr x2) {
ptr tc = get_thread_context();
S_initframe(tc, 2);
S_put_arg(tc, 1, x1);
S_put_arg(tc, 2, x2);
return S_call(tc, cp, 2);
}
ptr Scall3(ptr cp, ptr x1, ptr x2, ptr x3) {
ptr tc = get_thread_context();
S_initframe(tc, 3);
S_put_arg(tc, 1, x1);
S_put_arg(tc, 2, x2);
S_put_arg(tc, 3, x3);
return S_call(tc, cp, 3);
}
void Sinitframe(iptr n) {
ptr tc = get_thread_context();
S_initframe(tc, n);
}
void S_initframe(ptr tc, iptr n) {
/* check for and handle stack overflow */
if ((ptr *)SFP(tc) + n + 2 > (ptr *)ESP(tc))
S_overflow(tc, (n+2)*sizeof(ptr));
/* intermediate frame contains old RA + cchain */;
SFP(tc) = (ptr)((ptr *)SFP(tc) + 2);
}
void Sput_arg(iptr i, ptr x) {
ptr tc = get_thread_context();
S_put_arg(tc, i, x);
}
void S_put_arg(ptr tc, iptr i, ptr x) {
if (i <= asm_arg_reg_cnt)
REGARG(tc, i) = x;
else
FRAME(tc, i - asm_arg_reg_cnt) = x;
}
ptr Scall(ptr cp, iptr argcnt) {
ptr tc = get_thread_context();
return S_call(tc, cp, argcnt);
}
static ptr S_call(ptr tc, ptr cp, iptr argcnt) {
AC0(tc) = (ptr)argcnt;
AC1(tc) = cp;
S_call_help(tc, 1, 0);
return AC0(tc);
}
/* args are set up, argcnt in ac0, closure in ac1 */
void S_call_help(ptr tc_in, IBOOL singlep, IBOOL lock_ts) {
/* declaring code and tc volatile should be unnecessary, but it quiets gcc
and avoids occasional invalid memory violations on Windows */
void *jb; volatile ptr code;
volatile ptr tc = tc_in;
/* lock caller's code object, since his return address is sitting in
the C stack and we may end up in a garbage collection */
code = CP(tc);
if (Sprocedurep(code)) code = CLOSCODE(code);
if (!IMMEDIATE(code) && !Scodep(code))
S_error_abort("S_call_help: invalid code pointer");
Slock_object(code);
CP(tc) = AC1(tc);
jb = CREATEJMPBUF();
if (jb == NULL)
S_error_abort("unable to allocate memory for jump buffer");
if (lock_ts) {
/* Lock a code object passed in TS, which is a more immediate
caller whose return address is on the C stack */
Slock_object(TS(tc));
CCHAIN(tc) = Scons(Scons(jb, Scons(code,TS(tc))), CCHAIN(tc));
} else {
CCHAIN(tc) = Scons(Scons(jb, Scons(code,Sfalse)), CCHAIN(tc));
}
FRAME(tc, -1) = CCHAIN(tc);
switch (SETJMP(jb)) {
case 0: /* first time */
S_generic_invoke(tc, S_G.invoke_code_object);
S_error_abort("S_generic_invoke return");
break;
case -1: /* error */
S_generic_invoke(tc, S_G.error_invoke_code_object);
S_error_abort("S_generic_invoke return");
break;
case 1: { /* normal return */
ptr yp = CCHAIN(tc);
FREEJMPBUF(CAAR(yp));
CCHAIN(tc) = Scdr(yp);
break;
}
default:
S_error_abort("unexpected SETJMP return value");
break;
}
/* verify single return value */
if (singlep && (iptr)AC1(tc) != 1)
S_error1("", "returned ~s values to single value return context",
FIX((iptr)AC1(tc)));
/* restore caller to cp so that we can lock it again another day. we
restore the code object rather than the original closure, as the
closure may have been relocated or reclaimed by now */
CP(tc) = code;
}
void S_call_one_result(void) {
ptr tc = get_thread_context();
S_call_help(tc, 1, 1);
}
void S_call_any_results(void) {
ptr tc = get_thread_context();
S_call_help(tc, 0, 1);
}
/* cchain = ((jb . (co . maybe-co)) ...) */
void S_return(void) {
ptr tc = get_thread_context();
ptr xp, yp;
SFP(tc) = (ptr)((ptr *)SFP(tc) - 2);
/* grab saved cchain */
yp = FRAME(tc, 1);
/* verify saved cchain is sublist of current cchain */
for (xp = CCHAIN(tc); xp != yp; xp = Scdr(xp))
if (xp == Snil)
S_error("", "attempt to return to stale foreign context");
/* error checks are done; now unlock affected code objects */
for (xp = CCHAIN(tc); ; xp = Scdr(xp)) {
ptr p = CDAR(xp);
Sunlock_object(Scar(p));
if (Scdr(p) != Sfalse) Sunlock_object(Scdr(p));
if (xp == yp) break;
FREEJMPBUF(CAAR(xp));
}
/* reset cchain and return via longjmp */
CCHAIN(tc) = yp;
LONGJMP(CAAR(yp), 1);
}

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

Binary file not shown.

783
ta6ob/c/schsig.c Normal file
View file

@ -0,0 +1,783 @@
/* schsig.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 <setjmp.h>
/* locally defined functions */
static void S_promote_to_multishot(ptr k);
static void split(ptr k, ptr *s);
static void reset_scheme(void);
static NORETURN void do_error(iptr type, const char *who, const char *s, ptr args);
static void handle_call_error(ptr tc, iptr type, ptr x);
static void init_signal_handlers(void);
static void keyboard_interrupt(ptr tc);
ptr S_get_scheme_arg(ptr tc, iptr n) {
if (n <= asm_arg_reg_cnt) return REGARG(tc, n);
else return FRAME(tc, n - asm_arg_reg_cnt);
}
void S_put_scheme_arg(ptr tc, iptr n, ptr x) {
if (n <= asm_arg_reg_cnt) REGARG(tc, n) = x;
else FRAME(tc, n - asm_arg_reg_cnt) = x;
}
static void S_promote_to_multishot(ptr k) {
while (CONTLENGTH(k) != CONTCLENGTH(k)) {
CONTLENGTH(k) = CONTCLENGTH(k);
k = CONTLINK(k);
}
}
/* k must be is a multi-shot continuation, and s (the split point)
* must be strictly between the base and end of k's stack segment. */
static void split(ptr k, ptr *s) {
iptr m, n;
seginfo *si;
tc_mutex_acquire()
/* set m to size of lower piece, n to size of upper piece */
m = (uptr)s - (uptr)CONTSTACK(k);
n = CONTCLENGTH(k) - m;
si = SegInfo(ptr_get_segment(k));
/* insert a new continuation between k and link(k) */
CONTLINK(k) = S_mkcontinuation(si->space,
si->generation,
CLOSENTRY(k),
CONTSTACK(k),
m, m,
CONTLINK(k),
*s,
Snil);
CONTLENGTH(k) = CONTCLENGTH(k) = n;
CONTSTACK(k) = (ptr)s;
*s = (ptr)DOUNDERFLOW;
tc_mutex_release()
}
/* We may come in to S_split_and_resize with a multi-shot continuation whose
* stack segment exceeds the copy bound or is too large to fit along
* with the return values in the current stack. We may also come in to
* S_split_and_resize with a one-shot continuation for which all of the
* above is true and for which there is insufficient space between the
* top frame and the end of the stack. If we have to split a 1-shot, we
* promote it to multi-shot; doing otherwise is too much trouble. */
void S_split_and_resize(void) {
ptr tc = get_thread_context();
ptr k; iptr value_count; iptr n;
/* cp = continuation, ac0 = return value count */
k = CP(tc);
value_count = (iptr)AC0(tc);
if (CONTCLENGTH(k) > underflow_limit) {
iptr frame_size;
ptr *front_stack_ptr, *end_stack_ptr, *split_point, *guard;
front_stack_ptr = (ptr *)CONTSTACK(k);
end_stack_ptr = (ptr *)((uptr)front_stack_ptr + CONTCLENGTH(k));
guard = (ptr *)((uptr)end_stack_ptr - underflow_limit);
/* set split point to base of top frame */
frame_size = ENTRYFRAMESIZE(CONTRET(k));
split_point = (ptr *)((uptr)end_stack_ptr - frame_size);
/* split only if we have more than one frame */
if (split_point != front_stack_ptr) {
/* walk the stack to set split_point at first frame above guard */
/* note that first frame may have put us below the guard already */
for (;;) {
ptr *p;
frame_size = ENTRYFRAMESIZE(*split_point);
p = (ptr *)((uptr)split_point - frame_size);
if (p < guard) break;
split_point = p;
}
/* promote to multi-shot if necessary */
S_promote_to_multishot(k);
/* split */
split(k, split_point);
}
}
/* make sure the stack is big enough to hold continuation
* this is conservative: really need stack-base + clength <= esp
* and clength + size(values) < stack-size; also, size may include
* argument register values */
n = CONTCLENGTH(k) + (value_count * sizeof(ptr)) + stack_slop;
if (n >= SCHEMESTACKSIZE(tc)) {
tc_mutex_acquire()
S_reset_scheme_stack(tc, n);
tc_mutex_release()
}
}
iptr S_continuation_depth(ptr k) {
iptr n, frame_size; ptr *stack_base, *stack_ptr;
n = 0;
/* terminate on shot 1-shot, which could be null_continuation */
while (CONTLENGTH(k) != scaled_shot_1_shot_flag) {
stack_base = (ptr *)CONTSTACK(k);
frame_size = ENTRYFRAMESIZE(CONTRET(k));
stack_ptr = (ptr *)((uptr)stack_base + CONTCLENGTH(k));
for (;;) {
stack_ptr = (ptr *)((uptr)stack_ptr - frame_size);
n += 1;
if (stack_ptr == stack_base) break;
frame_size = ENTRYFRAMESIZE(*stack_ptr);
}
k = CONTLINK(k);
}
return n;
}
ptr S_single_continuation(ptr k, iptr n) {
iptr frame_size; ptr *stack_base, *stack_top, *stack_ptr;
/* bug out on shot 1-shots, which could be null_continuation */
while (CONTLENGTH(k) != scaled_shot_1_shot_flag) {
stack_base = (ptr *)CONTSTACK(k);
stack_top = (ptr *)((uptr)stack_base + CONTCLENGTH(k));
stack_ptr = stack_top;
frame_size = ENTRYFRAMESIZE(CONTRET(k));
for (;;) {
if (n == 0) {
/* promote to multi-shot if necessary, even if we don't end
* up in split, since inspector assumes multi-shot */
S_promote_to_multishot(k);
if (stack_ptr != stack_top) {
split(k, stack_ptr);
k = CONTLINK(k);
}
stack_ptr = (ptr *)((uptr)stack_ptr - frame_size);
if (stack_ptr != stack_base)
split(k, stack_ptr);
return k;
} else {
n -= 1;
stack_ptr = (ptr *)((uptr)stack_ptr - frame_size);
if (stack_ptr == stack_base) break;
frame_size = ENTRYFRAMESIZE(*stack_ptr);
}
}
k = CONTLINK(k);
}
return Sfalse;
}
void S_handle_overflow(void) {
ptr tc = get_thread_context();
/* default frame size is enough */
S_overflow(tc, 0);
}
void S_handle_overflood(void) {
ptr tc = get_thread_context();
/* xp points to where esp needs to be */
S_overflow(tc, ((ptr *)XP(tc) - (ptr *)SFP(tc))*sizeof(ptr));
}
void S_handle_apply_overflood(void) {
ptr tc = get_thread_context();
/* ac0 contains the argument count for the called procedure */
/* could reduce request by default frame size and number of arg registers */
/* the "+ 1" is for the return address slot */
S_overflow(tc, ((iptr)AC0(tc) + 1) * sizeof(ptr));
}
/* allocates a new stack
* --the old stack below the sfp is turned into a continuation
* --the old stack above the sfp is copied to the new stack
* --return address must be in first frame location
* --scheme registers are preserved or reset
* frame_request is how much (in bytes) to increase the default frame size
*/
void S_overflow(ptr tc, iptr frame_request) {
ptr *sfp;
iptr above_split_size, sfp_offset;
ptr *split_point, *guard, *other_guard;
iptr split_stack_length, split_stack_clength;
ptr nuate;
sfp = (ptr *)SFP(tc);
nuate = SYMVAL(S_G.nuate_id);
if (!Scodep(nuate)) {
S_error_abort("overflow: nuate not yet defined");
}
guard = (ptr *)((uptr)sfp - underflow_limit);
/* leave at least stack_slop headroom in the old stack to reduce the need for return-point overflow checks */
other_guard = (ptr *)((uptr)SCHEMESTACK(tc) + (uptr)SCHEMESTACKSIZE(tc) - (uptr)stack_slop);
if ((uptr)other_guard < (uptr)guard) guard = other_guard;
/* split only if old stack contains more than underflow_limit bytes */
if (guard > (ptr *)SCHEMESTACK(tc)) {
iptr frame_size;
/* set split point to base of the frame below the current one */
frame_size = ENTRYFRAMESIZE(*sfp);
split_point = (ptr *)((uptr)sfp - frame_size);
/* split only if we have more than one frame */
if (split_point != (ptr *)SCHEMESTACK(tc)) {
/* walk the stack to set split_point at first frame above guard */
/* note that first frame may have put us below the guard already */
for (;;) {
ptr *p;
frame_size = ENTRYFRAMESIZE(*split_point);
p = (ptr *)((uptr)split_point - frame_size);
if (p < guard) break;
split_point = p;
}
split_stack_clength = (uptr)split_point - (uptr)SCHEMESTACK(tc);
/* promote to multi-shot if current stack is shrimpy */
if (SCHEMESTACKSIZE(tc) < default_stack_size / 4) {
split_stack_length = split_stack_clength;
S_promote_to_multishot(STACKLINK(tc));
} else {
split_stack_length = SCHEMESTACKSIZE(tc);
}
/* create a continuation */
tc_mutex_acquire()
STACKLINK(tc) = S_mkcontinuation(space_new,
0,
CODEENTRYPOINT(nuate),
SCHEMESTACK(tc),
split_stack_length,
split_stack_clength,
STACKLINK(tc),
*split_point,
Snil);
tc_mutex_release()
/* overwrite old return address with dounderflow */
*split_point = (ptr)DOUNDERFLOW;
}
} else {
split_point = (ptr *)SCHEMESTACK(tc);
}
above_split_size = SCHEMESTACKSIZE(tc) - ((uptr)split_point - (uptr)SCHEMESTACK(tc));
/* allocate a new stack, retaining same relative sfp */
sfp_offset = (uptr)sfp - (uptr)split_point;
tc_mutex_acquire()
S_reset_scheme_stack(tc, above_split_size + frame_request);
tc_mutex_release()
SFP(tc) = (ptr)((uptr)SCHEMESTACK(tc) + sfp_offset);
/* copy up everything above the split point. we don't know where the
current frame ends, so we copy through the end of the old stack */
{ptr *p, *q; iptr n;
p = (ptr *)SCHEMESTACK(tc);
q = split_point;
for (n = above_split_size; n != 0; n -= sizeof(ptr)) *p++ = *q++;
}
}
void S_error_abort(const char *s) {
fprintf(stderr, "%s\n", s);
S_abnormal_exit();
}
void S_abnormal_exit(void) {
S_abnormal_exit_proc();
fprintf(stderr, "abnormal_exit procedure did not exit\n");
exit(1);
}
static void reset_scheme(void) {
ptr tc = get_thread_context();
tc_mutex_acquire()
/* eap should always be up-to-date now that we write-through to the tc
when making any changes to eap when eap is a real register */
S_scan_dirty((ptr **)EAP(tc), (ptr **)REAL_EAP(tc));
S_reset_allocation_pointer(tc);
S_reset_scheme_stack(tc, stack_slop);
FRAME(tc,0) = (ptr)DOUNDERFLOW;
tc_mutex_release()
}
/* error_resets occur with the system in an unknown state,
* thus we must reset with no opportunity for debugging
*/
void S_error_reset(const char *s) {
if (!S_errors_to_console) reset_scheme();
do_error(ERROR_RESET, "", s, Snil);
}
void S_error(const char *who, const char *s) {
do_error(ERROR_OTHER, who, s, Snil);
}
void S_error1(const char *who, const char *s, ptr x) {
do_error(ERROR_OTHER, who, s, LIST1(x));
}
void S_error2(const char *who, const char *s, ptr x, ptr y) {
do_error(ERROR_OTHER, who, s, LIST2(x,y));
}
void S_error3(const char *who, const char *s, ptr x, ptr y, ptr z) {
do_error(ERROR_OTHER, who, s, LIST3(x,y,z));
}
void S_boot_error(ptr who, ptr msg, ptr args) {
printf("error caught before error-handing subsystem initialized\n");
printf("who: ");
S_prin1(who);
printf("\nmsg: ");
S_prin1(msg);
printf("\nargs: ");
S_prin1(args);
printf("\n");
fflush(stdout);
S_abnormal_exit();
}
static void do_error(iptr type, const char *who, const char *s, ptr args) {
ptr tc = get_thread_context();
if (S_errors_to_console || tc == (ptr)0 || CCHAIN(tc) == Snil) {
if (strlen(who) == 0)
printf("Error: %s\n", s);
else
printf("Error in %s: %s\n", who, s);
S_prin1(args); putchar('\n');
fflush(stdout);
S_abnormal_exit();
}
args = Scons(FIX(type),
Scons((strlen(who) == 0 ? Sfalse : Sstring_utf8(who,-1)),
Scons(Sstring_utf8(s, -1), args)));
#ifdef PTHREADS
while (S_tc_mutex_depth > 0) {
S_mutex_release(&S_tc_mutex);
S_tc_mutex_depth -= 1;
}
#endif /* PTHREADS */
TRAP(tc) = (ptr)1;
AC0(tc) = (ptr)1;
CP(tc) = S_symbol_value(S_G.error_id);
S_put_scheme_arg(tc, 1, args);
LONGJMP(CAAR(CCHAIN(tc)), -1);
}
static void handle_call_error(ptr tc, iptr type, ptr x) {
ptr p, arg1;
iptr argcnt;
argcnt = (iptr)AC0(tc);
arg1 = argcnt == 0 ? Snil : S_get_scheme_arg(tc, 1);
p = Scons(FIX(type), Scons(FIX(argcnt), Scons(x, Scons(arg1, Snil))));
if (S_errors_to_console) {
printf("Call error: ");
S_prin1(p); putchar('\n'); fflush(stdout);
S_abnormal_exit();
}
CP(tc) = S_symbol_value(S_G.error_id);
S_put_scheme_arg(tc, 1, p);
AC0(tc) = (ptr)(argcnt==0 ? 1 : argcnt);
TRAP(tc) = (ptr)1; /* Why is this here? */
}
void S_handle_docall_error(void) {
ptr tc = get_thread_context();
handle_call_error(tc, ERROR_CALL_NONPROCEDURE, CP(tc));
}
void S_handle_arg_error(void) {
ptr tc = get_thread_context();
handle_call_error(tc, ERROR_CALL_ARGUMENT_COUNT, CP(tc));
}
void S_handle_nonprocedure_symbol(void) {
ptr tc = get_thread_context();
ptr s;
s = XP(tc);
handle_call_error(tc,
(SYMVAL(s) == sunbound ?
ERROR_CALL_UNBOUND :
ERROR_CALL_NONPROCEDURE_SYMBOL),
s);
}
void S_handle_values_error(void) {
ptr tc = get_thread_context();
handle_call_error(tc, ERROR_VALUES, Sfalse);
}
void S_handle_mvlet_error(void) {
ptr tc = get_thread_context();
handle_call_error(tc, ERROR_MVLET, Sfalse);
}
static void keyboard_interrupt(ptr tc) {
KEYBOARDINTERRUPTPENDING(tc) = Strue;
SOMETHINGPENDING(tc) = Strue;
}
/* used in printf below
static uptr list_length(ptr ls) {
uptr i = 0;
while (ls != Snil) { ls = Scdr(ls); i += 1; }
return i;
}
*/
void S_fire_collector(void) {
ptr crp_id = S_G.collect_request_pending_id;
/* printf("firing collector!\n"); fflush(stdout); */
if (!Sboolean_value(S_symbol_value(crp_id))) {
ptr ls;
/* printf("really firing collector!\n"); fflush(stdout); */
tc_mutex_acquire()
/* check again in case some other thread beat us to the punch */
if (!Sboolean_value(S_symbol_value(crp_id))) {
/* printf("firing collector nthreads = %d\n", list_length(S_threads)); fflush(stdout); */
S_set_symbol_value(crp_id, Strue);
for (ls = S_threads; ls != Snil; ls = Scdr(ls))
SOMETHINGPENDING(THREADTC(Scar(ls))) = Strue;
}
tc_mutex_release()
}
}
void S_noncontinuable_interrupt(void) {
ptr tc = get_thread_context();
reset_scheme();
KEYBOARDINTERRUPTPENDING(tc) = Sfalse;
do_error(ERROR_NONCONTINUABLE_INTERRUPT,"","",Snil);
}
#ifdef WIN32
ptr S_dequeue_scheme_signals(ptr tc) {
return Snil;
}
ptr S_allocate_scheme_signal_queue(void) {
return (ptr)0;
}
void S_register_scheme_signal(iptr sig) {
S_error("register_scheme_signal", "unsupported in this version");
}
/* code courtesy Bob Burger, burgerrg@sagian.com
We cannot call noncontinuable_interrupt, because we are not allowed
to perform a longjmp inside a signal handler; instead, we don't
handle the signal, which will cause the process to terminate.
*/
static BOOL WINAPI handle_signal(DWORD dwCtrlType) {
switch (dwCtrlType) {
case CTRL_C_EVENT:
case CTRL_BREAK_EVENT: {
#ifdef PTHREADS
/* get_thread_context() always returns 0, so assume main thread */
ptr tc = S_G.thread_context;
#else
ptr tc = get_thread_context();
#endif
if (!S_pants_down && Sboolean_value(KEYBOARDINTERRUPTPENDING(tc)))
return(FALSE);
keyboard_interrupt(tc);
return(TRUE);
}
}
return(FALSE);
}
static void init_signal_handlers(void) {
SetConsoleCtrlHandler(handle_signal, TRUE);
}
#else /* WIN32 */
#include <signal.h>
static void handle_signal(INT sig, siginfo_t *si, void *data);
static IBOOL enqueue_scheme_signal(ptr tc, INT sig);
static ptr allocate_scheme_signal_queue(void);
static void forward_signal_to_scheme(INT sig);
#define RESET_SIGNAL {\
sigset_t set;\
sigemptyset(&set);\
sigaddset(&set, sig);\
sigprocmask(SIG_UNBLOCK,&set,(sigset_t *)0);\
}
/* we buffer up to SIGNALQUEUESIZE - 1 unhandled signals, then start dropping them. */
#define SIGNALQUEUESIZE 64
static IBOOL scheme_signals_registered;
/* we use a simple queue for pending signals. signals are enqueued only by the
C signal handler and dequeued only by the Scheme event handler. since the signal
handler and event handler run in the same thread, there's no need for locks
or write barriers. */
struct signal_queue {
INT head;
INT tail;
INT data[SIGNALQUEUESIZE];
};
static IBOOL enqueue_scheme_signal(ptr tc, INT sig) {
struct signal_queue *queue = (struct signal_queue *)(SIGNALINTERRUPTQUEUE(tc));
/* ignore the signal if we failed to allocate the queue */
if (queue == NULL) return 0;
INT tail = queue->tail;
INT next_tail = tail + 1;
if (next_tail == SIGNALQUEUESIZE) next_tail = 0;
/* ignore the signal if the queue is full */
if (next_tail == queue->head) return 0;
queue->data[tail] = sig;
queue->tail = next_tail;
return 1;
}
ptr S_dequeue_scheme_signals(ptr tc) {
ptr ls = Snil;
struct signal_queue *queue = (struct signal_queue *)(SIGNALINTERRUPTQUEUE(tc));
if (queue == NULL) return ls;
INT head = queue->head;
INT tail = queue->tail;
INT i = tail;
while (i != head) {
if (i == 0) i = SIGNALQUEUESIZE;
i -= 1;
ls = Scons(Sfixnum(queue->data[i]), ls);
}
queue->head = tail;
return ls;
}
static void forward_signal_to_scheme(INT sig) {
ptr tc = get_thread_context();
if (enqueue_scheme_signal(tc, sig)) {
SIGNALINTERRUPTPENDING(tc) = Strue;
SOMETHINGPENDING(tc) = Strue;
}
RESET_SIGNAL
}
static ptr allocate_scheme_signal_queue(void) {
/* silently fail to allocate space for signals if malloc returns NULL */
struct signal_queue *queue = malloc(sizeof(struct signal_queue));
if (queue != (struct signal_queue *)0) {
queue->head = queue->tail = 0;
}
return (ptr)queue;
}
ptr S_allocate_scheme_signal_queue(void) {
return scheme_signals_registered ? allocate_scheme_signal_queue() : (ptr)0;
}
void S_register_scheme_signal(iptr sig) {
struct sigaction act;
tc_mutex_acquire()
if (!scheme_signals_registered) {
ptr ls;
scheme_signals_registered = 1;
for (ls = S_threads; ls != Snil; ls = Scdr(ls)) {
SIGNALINTERRUPTQUEUE(THREADTC(Scar(ls))) = S_allocate_scheme_signal_queue();
}
}
tc_mutex_release()
sigfillset(&act.sa_mask);
act.sa_flags = 0;
act.sa_handler = forward_signal_to_scheme;
sigaction(sig, &act, (struct sigaction *)0);
}
static void handle_signal(INT sig, UNUSED siginfo_t *si, UNUSED void *data) {
/* printf("handle_signal(%d) for tc %x\n", sig, UNFIX(get_thread_context())); fflush(stdout); */
/* check for particular signals */
switch (sig) {
case SIGINT: {
ptr tc = get_thread_context();
/* disable keyboard interrupts in subordinate threads until we think
of something more clever to do with them */
if (tc == S_G.thread_context) {
if (!S_pants_down && Sboolean_value(KEYBOARDINTERRUPTPENDING(tc))) {
/* this is a no-no, but the only other options are to ignore
the signal or to kill the process */
RESET_SIGNAL
S_noncontinuable_interrupt();
}
keyboard_interrupt(tc);
}
RESET_SIGNAL
break;
}
#ifdef SIGQUIT
case SIGQUIT:
RESET_SIGNAL
S_abnormal_exit();
#endif /* SIGQUIT */
case SIGILL:
RESET_SIGNAL
S_error_reset("illegal instruction");
case SIGFPE:
RESET_SIGNAL
S_error_reset("arithmetic overflow");
#ifdef SIGBUS
case SIGBUS:
#endif /* SIGBUS */
case SIGSEGV:
RESET_SIGNAL
if (S_pants_down)
S_error_abort("nonrecoverable invalid memory reference");
else
S_error_reset("invalid memory reference");
default:
RESET_SIGNAL
S_error_reset("unexpected signal");
}
}
static void init_signal_handlers(void) {
struct sigaction act;
sigemptyset(&act.sa_mask);
/* drop pending keyboard interrupts */
act.sa_flags = 0;
act.sa_handler = SIG_IGN;
sigaction(SIGINT, &act, (struct sigaction *)0);
/* ignore broken pipe signals */
act.sa_flags = 0;
act.sa_handler = SIG_IGN;
sigaction(SIGPIPE, &act, (struct sigaction *)0);
/* set up to catch SIGINT w/no system call restart */
#ifdef SA_INTERRUPT
act.sa_flags = SA_INTERRUPT|SA_SIGINFO;
#else
act.sa_flags = SA_SIGINFO;
#endif /* SA_INTERRUPT */
act.sa_sigaction = handle_signal;
sigaction(SIGINT, &act, (struct sigaction *)0);
#ifdef BSDI
siginterrupt(SIGINT, 1);
#endif
/* set up to catch selected signals */
act.sa_flags = SA_SIGINFO;
act.sa_sigaction = handle_signal;
#ifdef SA_RESTART
act.sa_flags |= SA_RESTART;
#endif /* SA_RESTART */
#ifdef SIGQUIT
sigaction(SIGQUIT, &act, (struct sigaction *)0);
#endif /* SIGQUIT */
sigaction(SIGILL, &act, (struct sigaction *)0);
sigaction(SIGFPE, &act, (struct sigaction *)0);
#ifdef SIGBUS
sigaction(SIGBUS, &act, (struct sigaction *)0);
#endif /* SIGBUS */
sigaction(SIGSEGV, &act, (struct sigaction *)0);
}
#endif /* WIN32 */
void S_schsig_init(void) {
if (S_boot_time) {
ptr p;
S_protect(&S_G.nuate_id);
S_G.nuate_id = S_intern((const unsigned char *)"$nuate");
S_set_symbol_value(S_G.nuate_id, FIX(0));
S_protect(&S_G.null_continuation_id);
S_G.null_continuation_id = S_intern((const unsigned char *)"$null-continuation");
S_protect(&S_G.collect_request_pending_id);
S_G.collect_request_pending_id = S_intern((const unsigned char *)"$collect-request-pending");
p = S_code(get_thread_context(), type_code | (code_flag_continuation << code_flags_offset), 0);
CODERELOC(p) = S_relocation_table(0);
CODENAME(p) = Sfalse;
CODEARITYMASK(p) = FIX(0);
CODEFREE(p) = 0;
CODEINFO(p) = Sfalse;
CODEPINFOS(p) = Snil;
S_set_symbol_value(S_G.null_continuation_id,
S_mkcontinuation(space_new,
0,
CODEENTRYPOINT(p),
FIX(0),
scaled_shot_1_shot_flag, scaled_shot_1_shot_flag,
FIX(0),
FIX(0),
Snil));
S_protect(&S_G.error_id);
S_G.error_id = S_intern((const unsigned char *)"$c-error");
#ifndef WIN32
scheme_signals_registered = 0;
#endif
}
S_pants_down = 0;
S_set_symbol_value(S_G.collect_request_pending_id, Sfalse);
init_signal_handlers();
}

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

Binary file not shown.

503
ta6ob/c/segment.c Normal file
View file

@ -0,0 +1,503 @@
/* segment.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.
*/
/*
Low-level Memory management strategy:
* use getmem-allocated multiple-segment chunks of memory
* maintain getmem-allocated list of chunks
* maintain getmem-allocated segment info and dirty vector tables
* after each collection, run through the list of chunks. If all
segments in a chunk are empty, the chunk is a candidate for return
to the O/S. Return (freemem) as many chunks as possible without going
below a user-defined threshold of empty segments (determined as a
multiple of the occupied nonstatic segments). Bias return to the
most recently allocated chunks.
* getmem/freemem may be implemented with malloc/free; we use them
relatively infrequently so performance isn't an issue.
*/
#define debug(x) ;
/* #define debug(x) {x; fflush(stdout);} */
#include "system.h"
#include "sort.h"
#include <sys/types.h>
static void out_of_memory(void);
static void initialize_seginfo(seginfo *si, ISPC s, IGEN g);
static seginfo *allocate_segments(uptr nreq);
static void expand_segment_table(uptr base, uptr end, seginfo *si);
static void contract_segment_table(uptr base, uptr end);
static void add_to_chunk_list(chunkinfo *chunk, chunkinfo **pchunk_list);
static seginfo *sort_seginfo(seginfo *si, uptr n);
static seginfo *merge_seginfo(seginfo *si1, seginfo *si2);
void S_segment_init(void) {
IGEN g; ISPC s; int i;
if (!S_boot_time) return;
S_chunks_full = NULL;
for (i = PARTIAL_CHUNK_POOLS; i >= 0; i -= 1) S_chunks[i] = NULL;
for (g = 0; g <= static_generation; g++) {
for (s = 0; s <= max_real_space; s++) {
S_G.occupied_segments[g][s] = NULL;
}
}
S_G.number_of_nonstatic_segments = 0;
S_G.number_of_empty_segments = 0;
}
static uptr membytes = 0;
static uptr maxmembytes = 0;
static void out_of_memory(void) {
(void) fprintf(stderr,"out of memory\n");
S_abnormal_exit();
}
#if defined(USE_MALLOC)
void *S_getmem(iptr bytes, IBOOL zerofill) {
void *addr;
if ((addr = malloc(bytes)) == (void *)0) out_of_memory();
debug(printf("getmem(%p) -> %p\n", bytes, addr))
if ((membytes += bytes) > maxmembytes) maxmembytes = membytes;
if (zerofill) memset(addr, 0, bytes);
return addr;
}
void S_freemem(void *addr, iptr bytes) {
debug(printf("freemem(%p, %p)\n", addr, bytes))
free(addr);
membytes -= bytes;
}
#endif
#if defined(USE_VIRTUAL_ALLOC)
#include <winbase.h>
void *S_getmem(iptr bytes, IBOOL zerofill) {
void *addr;
if ((uptr)bytes < S_pagesize) {
if ((addr = malloc(bytes)) == (void *)0) out_of_memory();
debug(printf("getmem malloc(%p) -> %p\n", bytes, addr))
if ((membytes += bytes) > maxmembytes) maxmembytes = membytes;
if (zerofill) memset(addr, 0, bytes);
} else {
uptr n = S_pagesize - 1; iptr p_bytes = (iptr)(((uptr)bytes + n) & ~n);
if ((addr = VirtualAlloc((void *)0, (SIZE_T)p_bytes, MEM_COMMIT, PAGE_EXECUTE_READWRITE)) == (void *)0) out_of_memory();
if ((membytes += p_bytes) > maxmembytes) maxmembytes = membytes;
debug(printf("getmem VirtualAlloc(%p => %p) -> %p\n", bytes, p_bytes, addr))
}
return addr;
}
void S_freemem(void *addr, iptr bytes) {
if ((uptr)bytes < S_pagesize) {
debug(printf("freemem free(%p, %p)\n", addr, bytes))
membytes -= bytes;
free(addr);
} else {
uptr n = S_pagesize - 1; iptr p_bytes = (iptr)(((uptr)bytes + n) & ~n);
debug(printf("freemem VirtualFree(%p, %p => %p)\n", addr, bytes, p_bytes))
membytes -= p_bytes;
VirtualFree(addr, 0, MEM_RELEASE);
}
}
#endif
#if defined(USE_MMAP)
#include <sys/mman.h>
#ifndef MAP_ANONYMOUS
#define MAP_ANONYMOUS MAP_ANON
#endif
void *S_getmem(iptr bytes, IBOOL zerofill) {
void *addr;
if ((uptr)bytes < S_pagesize) {
if ((addr = malloc(bytes)) == (void *)0) out_of_memory();
debug(printf("getmem malloc(%p) -> %p\n", bytes, addr))
if ((membytes += bytes) > maxmembytes) maxmembytes = membytes;
if (zerofill) memset(addr, 0, bytes);
} else {
uptr n = S_pagesize - 1; iptr p_bytes = (iptr)(((uptr)bytes + n) & ~n);
#ifdef MAP_32BIT
/* try for first 2GB of the memory space first of x86_64 so that we have a
better chance of having short jump instructions */
if ((addr = mmap(NULL, p_bytes, PROT_EXEC|PROT_WRITE|PROT_READ, MAP_PRIVATE|MAP_ANONYMOUS|MAP_32BIT, -1, 0)) == (void *)-1) {
#endif
if ((addr = mmap(NULL, p_bytes, PROT_EXEC|PROT_WRITE|PROT_READ, MAP_PRIVATE|MAP_ANONYMOUS, -1, 0)) == (void *)-1) {
out_of_memory();
debug(printf("getmem mmap(%p) -> %p\n", bytes, addr))
}
#ifdef MAP_32BIT
}
#endif
if ((membytes += p_bytes) > maxmembytes) maxmembytes = membytes;
debug(printf("getmem mmap(%p => %p) -> %p\n", bytes, p_bytes, addr))
}
return addr;
}
void S_freemem(void *addr, iptr bytes) {
if ((uptr)bytes < S_pagesize) {
debug(printf("freemem free(%p, %p)\n", addr, bytes))
free(addr);
membytes -= bytes;
} else {
uptr n = S_pagesize - 1; iptr p_bytes = (iptr)(((uptr)bytes + n) & ~n);
debug(printf("freemem munmap(%p, %p => %p)\n", addr, bytes, p_bytes))
munmap(addr, p_bytes);
membytes -= p_bytes;
}
}
#endif
void S_move_to_chunk_list(chunkinfo *chunk, chunkinfo **pchunk_list) {
if ((*chunk->prev = chunk->next) != NULL) chunk->next->prev = chunk->prev;
add_to_chunk_list(chunk, pchunk_list);
}
static void add_to_chunk_list(chunkinfo *chunk, chunkinfo **pchunk_list) {
if ((chunk->next = *pchunk_list) != NULL) (*pchunk_list)->prev = &chunk->next;
chunk->prev = pchunk_list;
*pchunk_list = chunk;
}
#define SEGLT(x, y) ((x)->number < (y)->number)
#define SEGCDR(x) ((x)->next)
mkmergesort(sort_seginfo, merge_seginfo, seginfo *, NULL, SEGLT, SEGCDR)
static void sort_chunk_unused_segments(chunkinfo *chunk) {
seginfo *si, *nextsi, *sorted, *unsorted; uptr n;
/* bail out early if we find the unused segments list is already sorted */
if ((unsorted = chunk->unused_segs)->sorted) return;
/* find the sorted tail so we can just sort in the unsorted ones */
si = unsorted;
n = 1;
for (;;) {
si->sorted = 1;
if ((nextsi = si->next) == NULL || nextsi->sorted) {
sorted = nextsi;
si->next = NULL;
break;
}
si = nextsi;
n += 1;
}
sorted = merge_seginfo(sort_seginfo(unsorted, n), sorted);
chunk->unused_segs = sorted;
}
static INT find_index(iptr n) {
INT index = (INT)((n >> 2) + 1);
return (index < PARTIAL_CHUNK_POOLS-1) ? index : PARTIAL_CHUNK_POOLS-1;
}
static void initialize_seginfo(seginfo *si, ISPC s, IGEN g) {
INT d;
si->space = s;
si->generation = g;
si->sorted = 0;
si->min_dirty_byte = 0xff;
si->trigger_ephemerons = NULL;
for (d = 0; d < cards_per_segment; d += sizeof(ptr)) {
iptr *dp = (iptr *)(si->dirty_bytes + d);
/* fill sizeof(iptr) bytes at a time with 0xff */
*dp = -1;
}
}
iptr S_find_segments(ISPC s, IGEN g, iptr n) {
chunkinfo *chunk, *nextchunk;
seginfo *si, *nextsi, **prevsi;
iptr nunused_segs, j;
INT i, loser_index;
if (g != static_generation) S_G.number_of_nonstatic_segments += n;
debug(printf("attempting to find %d segments for space %d, generation %d\n", n, s, g))
if (n == 1) {
for (i = 0; i <= PARTIAL_CHUNK_POOLS; i++) {
chunk = S_chunks[i];
if (chunk != NULL) {
si = chunk->unused_segs;
chunk->unused_segs = si->next;
if (chunk->unused_segs == NULL) {
S_move_to_chunk_list(chunk, &S_chunks_full);
} else if (i == PARTIAL_CHUNK_POOLS) {
S_move_to_chunk_list(chunk, &S_chunks[PARTIAL_CHUNK_POOLS-1]);
}
chunk->nused_segs += 1;
initialize_seginfo(si, s, g);
si->next = S_G.occupied_segments[g][s];
S_G.occupied_segments[g][s] = si;
S_G.number_of_empty_segments -= 1;
return si->number;
}
}
} else {
loser_index = (n == 2) ? 0 : find_index(n-1);
for (i = find_index(n); i <= PARTIAL_CHUNK_POOLS; i += 1) {
chunk = S_chunks[i];
while (chunk != NULL) {
if (n < (nunused_segs = (chunk->segs - chunk->nused_segs))) {
sort_chunk_unused_segments(chunk);
si = chunk->unused_segs;
prevsi = &chunk->unused_segs;
while (nunused_segs >= n) {
nextsi = si;
j = n - 1;
for (;;) {
nunused_segs -= 1;
if (nextsi->number + 1 != nextsi->next->number) {
si = nextsi->next;
prevsi = &nextsi->next;
break;
}
nextsi = nextsi->next;
if (--j == 0) {
*prevsi = nextsi->next;
if (chunk->unused_segs == NULL) {
S_move_to_chunk_list(chunk, &S_chunks_full);
} else if (i == PARTIAL_CHUNK_POOLS) {
S_move_to_chunk_list(chunk, &S_chunks[PARTIAL_CHUNK_POOLS-1]);
}
chunk->nused_segs += n;
nextsi->next = S_G.occupied_segments[g][s];
S_G.occupied_segments[g][s] = si;
for (j = n, nextsi = si; j > 0; j -= 1, nextsi = nextsi->next) {
initialize_seginfo(nextsi, s, g);
}
S_G.number_of_empty_segments -= n;
return si->number;
}
}
}
}
nextchunk = chunk->next;
if (i != loser_index && i != PARTIAL_CHUNK_POOLS) {
S_move_to_chunk_list(chunk, &S_chunks[loser_index]);
}
chunk = nextchunk;
}
}
}
/* we couldn't find space, so ask for more */
si = allocate_segments(n);
for (nextsi = si; n > 0; n -= 1, nextsi += 1) {
initialize_seginfo(nextsi, s, g);
/* add segment to appropriate list of occupied segments */
nextsi->next = S_G.occupied_segments[g][s];
S_G.occupied_segments[g][s] = nextsi;
}
return si->number;
}
/* allocate_segments(n)
* allocates a group of n contiguous fresh segments, returning the
* segment number of the first segment of the group.
*/
static seginfo *allocate_segments(nreq) uptr nreq; {
uptr nact, bytes, base; void *addr;
iptr i;
chunkinfo *chunk; seginfo *si;
nact = nreq < minimum_segment_request ? minimum_segment_request : nreq;
bytes = (nact + 1) * bytes_per_segment;
addr = S_getmem(bytes, 0);
debug(printf("allocate_segments addr = %p\n", addr))
base = addr_get_segment((uptr)addr + bytes_per_segment - 1);
/* if the base of the first segment is the same as the base of the chunk, and
the last segment isn't the last segment in memory (which could cause 'next' and 'end'
pointers to wrap), we've actually got nact + 1 usable segments in this chunk */
if (build_ptr(base, 0) == addr && base + nact != ((uptr)1 << (ptr_bits - segment_offset_bits)) - 1)
nact += 1;
chunk = S_getmem(sizeof(chunkinfo) + sizeof(seginfo) * nact, 0);
debug(printf("allocate_segments chunk = %p\n", chunk))
chunk->addr = addr;
chunk->base = base;
chunk->bytes = bytes;
chunk->segs = nact;
chunk->nused_segs = nreq;
chunk->unused_segs = NULL;
expand_segment_table(base, base + nact, &chunk->sis[0]);
/* initialize seginfos */
for (i = nact - 1; i >= 0; i -= 1) {
si = &chunk->sis[i];
si->chunk = chunk;
si->number = i + base;
if (i >= (iptr)nreq) {
si->space = space_empty;
si->generation = 0;
si->sorted = 1; /* inserting in reverse order, so emptys are always sorted */
si->next = chunk->unused_segs;
chunk->unused_segs = si;
}
}
/* account for trailing empty segments */
if (nact > nreq) {
S_G.number_of_empty_segments += nact - nreq;
add_to_chunk_list(chunk, &S_chunks[PARTIAL_CHUNK_POOLS-1]);
} else {
add_to_chunk_list(chunk, &S_chunks_full);
}
return &chunk->sis[0];
}
void S_free_chunk(chunkinfo *chunk) {
chunkinfo *nextchunk = chunk->next;
contract_segment_table(chunk->base, chunk->base + chunk->segs);
S_G.number_of_empty_segments -= chunk->segs;
*chunk->prev = nextchunk;
if (nextchunk != NULL) nextchunk->prev = chunk->prev;
S_freemem(chunk->addr, chunk->bytes);
S_freemem(chunk, sizeof(chunkinfo) + sizeof(seginfo) * chunk->segs);
}
/* retain approximately heap-reserve-ratio segments for every
* nonempty nonstatic segment. */
void S_free_chunks(void) {
iptr ntofree;
chunkinfo *chunk, *nextchunk;
ntofree = S_G.number_of_empty_segments -
(iptr)(Sflonum_value(SYMVAL(S_G.heap_reserve_ratio_id)) * S_G.number_of_nonstatic_segments);
for (chunk = S_chunks[PARTIAL_CHUNK_POOLS]; ntofree > 0 && chunk != NULL; chunk = nextchunk) {
nextchunk = chunk->next;
ntofree -= chunk->segs;
S_free_chunk(chunk);
}
}
uptr S_curmembytes(void) {
return membytes;
}
uptr S_maxmembytes(void) {
return maxmembytes;
}
void S_resetmaxmembytes(void) {
maxmembytes = membytes;
}
static void expand_segment_table(uptr base, uptr end, seginfo *si) {
#ifdef segment_t2_bits
#ifdef segment_t3_bits
t2table *t2i;
#endif
t1table **t2, *t1i; uptr n;
#endif
seginfo **t1, **t1end;
#ifdef segment_t2_bits
while (base != end) {
#ifdef segment_t3_bits
if ((t2i = S_segment_info[SEGMENT_T3_IDX(base)]) == NULL) {
S_segment_info[SEGMENT_T3_IDX(base)] = t2i = (t2table *)S_getmem(sizeof(t2table), 1);
}
t2 = t2i->t2;
#else
t2 = S_segment_info;
#endif
if ((t1i = t2[SEGMENT_T2_IDX(base)]) == NULL) {
t2[SEGMENT_T2_IDX(base)] = t1i = (t1table *)S_getmem(sizeof(t1table), 1);
#ifdef segment_t3_bits
t2i->refcount += 1;
#endif
}
t1 = t1i->t1 + SEGMENT_T1_IDX(base);
t1end = t1 + end - base < t1i->t1 + SEGMENT_T1_SIZE ? t1 + end - base : t1i->t1 + SEGMENT_T1_SIZE;
n = t1end - t1;
t1i->refcount += n;
while (t1 < t1end) *t1++ = si++;
base += n;
}
#else
t1 = S_segment_info + SEGMENT_T1_IDX(base);
t1end = t1 + end - base;
while (t1 < t1end) *t1++ = si++;
#endif
}
static void contract_segment_table(uptr base, uptr end) {
#ifdef segment_t2_bits
#ifdef segment_t3_bits
t2table *t2i;
#endif
t1table **t2, *t1i; uptr n;
#endif
seginfo **t1, **t1end;
#ifdef segment_t2_bits
while (base != end) {
#ifdef segment_t3_bits
t2i = S_segment_info[SEGMENT_T3_IDX(base)];
t2 = t2i->t2;
#else
t2 = S_segment_info;
#endif
t1i = t2[SEGMENT_T2_IDX(base)];
t1 = t1i->t1 + SEGMENT_T1_IDX(base);
t1end = t1 + end - base < t1i->t1 + SEGMENT_T1_SIZE ? t1 + end - base : t1i->t1 + SEGMENT_T1_SIZE;
n = t1end - t1;
if ((t1i->refcount -= n) == 0) {
S_freemem((void *)t1i, sizeof(t1table));
#ifdef segment_t3_bits
if ((t2i->refcount -= 1) == 0) {
S_freemem((void *)t2i, sizeof(t2table));
S_segment_info[SEGMENT_T3_IDX(base)] = NULL;
} else {
S_segment_info[SEGMENT_T3_IDX(base)]->t2[SEGMENT_T2_IDX(base)] = NULL;
}
#else
S_segment_info[SEGMENT_T2_IDX(base)] = NULL;
#endif
} else {
while (t1 < t1end) *t1++ = NULL;
}
base += n;
}
#else
t1 = S_segment_info + SEGMENT_T1_IDX(base);
t1end = t1 + end - base;
while (t1 < t1end) *t1++ = NULL;
#endif
}

83
ta6ob/c/segment.h Normal file
View file

@ -0,0 +1,83 @@
/* segment.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.
*/
#ifdef WIN32
# ifndef __MINGW32__
# undef FORCEINLINE
# define FORCEINLINE static __forceinline
# endif
#else
#define FORCEINLINE static inline
#endif
/* segment_info */
#define SEGMENT_T1_SIZE (1<<segment_t1_bits)
#define SEGMENT_T1_IDX(i) ((i)&(SEGMENT_T1_SIZE-1))
#ifdef segment_t3_bits
#define SEGMENT_T2_SIZE (1<<segment_t2_bits)
#define SEGMENT_T2_IDX(i) (((i)>>segment_t1_bits)&(SEGMENT_T2_SIZE-1))
#define SEGMENT_T3_SIZE (1<<segment_t3_bits)
#define SEGMENT_T3_IDX(i) ((i)>>(segment_t2_bits+segment_t1_bits))
FORCEINLINE seginfo *SegInfo(uptr i) {
return S_segment_info[SEGMENT_T3_IDX(i)]->t2[SEGMENT_T2_IDX(i)]->t1[SEGMENT_T1_IDX(i)];
}
FORCEINLINE seginfo *MaybeSegInfo(uptr i) {
t2table *t2i; t1table *t1i;
if ((t2i = S_segment_info[SEGMENT_T3_IDX(i)]) == NULL) return NULL;
if ((t1i = t2i->t2[SEGMENT_T2_IDX(i)]) == NULL) return NULL;
return t1i->t1[SEGMENT_T1_IDX(i)];
}
#else /* segment_t3_bits */
#ifdef segment_t2_bits
#define SEGMENT_T2_SIZE (1<<segment_t2_bits)
#define SEGMENT_T2_IDX(i) ((i)>>segment_t1_bits)
#define SEGMENT_T3_SIZE 0
FORCEINLINE seginfo *SegInfo(uptr i) {
return S_segment_info[SEGMENT_T2_IDX(i)]->t1[SEGMENT_T1_IDX(i)];
}
FORCEINLINE seginfo *MaybeSegInfo(uptr i) {
t1table *t1i;
if ((t1i = S_segment_info[SEGMENT_T2_IDX(i)]) == NULL) return NULL;
return t1i->t1[SEGMENT_T1_IDX(i)];
}
#else /* segment_t2_bits */
#define SEGMENT_T2_SIZE 0
#define SEGMENT_T3_SIZE 0
FORCEINLINE seginfo *SegInfo(uptr i) {
return S_segment_info[SEGMENT_T1_IDX(i)];
}
FORCEINLINE seginfo *MaybeSegInfo(uptr i) {
return S_segment_info[SEGMENT_T1_IDX(i)];
}
#endif /* segment_t2_bits */
#endif /* segment_t3_bits */
#define SegmentSpace(i) (SegInfo(i)->space)
#define SegmentGeneration(i) (SegInfo(i)->generation)

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

Binary file not shown.

40
ta6ob/c/sort.h Normal file
View file

@ -0,0 +1,40 @@
/* sort.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.
*/
#define mkmergesort(sort, merge, type, nil, lt, cdr)\
type sort(type ls, uptr len) {\
if (len == 1) {\
cdr(ls) = nil;\
return ls;\
} else {\
uptr head_len, i; type tail;\
head_len = len >> 1;\
for (tail = ls, i = head_len; i != 0; i -= 1) tail = cdr(tail);\
return merge(sort(ls, head_len), sort(tail, len - head_len));\
}\
}\
type merge(type ls1, type ls2) {\
type p; type *pp = &p;\
for (;;) {\
if (ls1 == nil) { *pp = ls2; break; }\
if (ls2 == nil) { *pp = ls1; break; }\
if (lt(ls2, ls1))\
{ *pp = ls2; pp = &cdr(ls2); ls2 = cdr(ls2); }\
else\
{ *pp = ls1; pp = &cdr(ls1); ls1 = cdr(ls1); }\
}\
return p;\
}

22
ta6ob/c/statics.c Normal file
View file

@ -0,0 +1,22 @@
/* statics.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 EXTERN
#include "system.h"
/* The C linker may require a reference to a function to pull in all
the common declarations. */
void scheme_statics(void) { }

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

Binary file not shown.

528
ta6ob/c/stats.c Normal file
View file

@ -0,0 +1,528 @@
/* stats.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.
*/
#if defined(SOLARIS)
/* make gmtime_r and localtime_r visible */
#ifndef _REENTRANT
#define _REENTRANT
#endif
/* make two-argument ctime_r and two-argument asctime_r visible */
#define _POSIX_PTHREAD_SEMANTICS
#endif /* defined(SOLARIS) */
#include "system.h"
#ifdef WIN32
#include <sys/types.h>
#include <sys/timeb.h>
#else /* WIN32 */
#include <sys/types.h>
#include <sys/time.h>
#include <sys/resource.h>
#endif
static struct timespec starting_mono_tp;
static long adjust_time_zone(ptr dtvec, struct tm *tmxp, ptr given_tzoff);
/******** unique-id ********/
#if (time_t_bits == 32)
#define S_integer_time_t(x) Sinteger32((iptr)(x))
#elif (time_t_bits == 64)
#define S_integer_time_t(x) Sinteger64(x)
#endif
#ifdef WIN32
#include <rpc.h>
ptr S_unique_id(void) {
union {UUID uuid; U32 foo[4];} u;
u.foo[0] = 0;
u.foo[1] = 0;
u.foo[2] = 0;
u.foo[3] = 0;
UuidCreate(&u.uuid);
return S_add(S_ash(Sunsigned32(u.foo[0]), Sinteger(8*3*sizeof(U32))),
S_add(S_ash(Sunsigned32(u.foo[1]), Sinteger(8*2*sizeof(U32))),
S_add(S_ash(Sunsigned32(u.foo[2]), Sinteger(8*sizeof(U32))),
Sunsigned32(u.foo[3]))));
}
#elif defined(USE_OSSP_UUID) /* WIN32 */
#include <ossp/uuid.h>
ptr S_unique_id(void) {
uuid_t *uuid;
U32 bin[4];
void *bin_ptr = &bin;
size_t bin_len = sizeof(bin);
uuid_create(&uuid);
uuid_make(uuid, UUID_MAKE_V4);
uuid_export(uuid, UUID_FMT_BIN, &bin_ptr, &bin_len);
uuid_destroy(uuid);
return S_add(S_ash(Sunsigned32(bin[0]), Sinteger(8*3*sizeof(U32))),
S_add(S_ash(Sunsigned32(bin[1]), Sinteger(8*2*sizeof(U32))),
S_add(S_ash(Sunsigned32(bin[2]), Sinteger(8*sizeof(U32))),
Sunsigned32(bin[3]))));
}
#elif defined(USE_NETBSD_UUID) /* USE_OSSP_UUID */
#include <uuid.h>
ptr S_unique_id(void) {
uuid_t uuid;
uint32_t status;
unsigned char bin[16];
ptr n;
unsigned int i;
uuid_create(&uuid, &status);
uuid_enc_le(bin, &uuid);
n = Sinteger(0);
for (i = 0; i < sizeof(bin); i++) {
n = S_add(n, S_ash(Sinteger(bin[i]), Sinteger(8*i)));
}
return n;
}
#else /* USE_NETBSD_UUID */
#include <uuid/uuid.h>
ptr S_unique_id(void) {
union {uuid_t uuid; U32 foo[4];} u;
u.foo[0] = 0;
u.foo[1] = 0;
u.foo[2] = 0;
u.foo[3] = 0;
uuid_generate(u.uuid);
return S_add(S_ash(Sunsigned32(u.foo[0]), Sinteger(8*3*sizeof(U32))),
S_add(S_ash(Sunsigned32(u.foo[1]), Sinteger(8*2*sizeof(U32))),
S_add(S_ash(Sunsigned32(u.foo[2]), Sinteger(8*sizeof(U32))),
Sunsigned32(u.foo[3]))));
}
#endif /* WIN32 */
/******** time and date support ********/
#ifdef WIN32
static __int64 hires_cps = 0;
typedef void (WINAPI *GetSystemTimeAsFileTime_t)(LPFILETIME lpSystemTimeAsFileTime);
static GetSystemTimeAsFileTime_t s_GetSystemTimeAsFileTime = GetSystemTimeAsFileTime;
void S_gettime(INT typeno, struct timespec *tp) {
switch (typeno) {
case time_process: {
FILETIME ftKernel, ftUser, ftDummy;
if (GetProcessTimes(GetCurrentProcess(), &ftDummy, &ftDummy,
&ftKernel, &ftUser)) {
__int64 kernel, user, total;
kernel = ftKernel.dwHighDateTime;
kernel <<= 32;
kernel |= ftKernel.dwLowDateTime;
user = ftUser.dwHighDateTime;
user <<= 32;
user |= ftUser.dwLowDateTime;
total = user + kernel;
tp->tv_sec = (time_t)(total / 10000000);
tp->tv_nsec = (long)((total % 10000000) * 100);
break;
} else {
clock_t n = clock();;
/* if GetProcessTimes fails, we're probably running Windows 95 */
tp->tv_sec = (time_t)(n / CLOCKS_PER_SEC);
tp->tv_nsec = (long)((n % CLOCKS_PER_SEC) * (1000000000 / CLOCKS_PER_SEC));
break;
}
}
case time_thread: {
FILETIME ftKernel, ftUser, ftDummy;
if (GetThreadTimes(GetCurrentThread(), &ftDummy, &ftDummy,
&ftKernel, &ftUser)) {
__int64 kernel, user, total;
kernel = ftKernel.dwHighDateTime;
kernel <<= 32;
kernel |= ftKernel.dwLowDateTime;
user = ftUser.dwHighDateTime;
user <<= 32;
user |= ftUser.dwLowDateTime;
total = user + kernel;
tp->tv_sec = (time_t)(total / 10000000);
tp->tv_nsec = (long)((total % 10000000) * 100);
break;
} else {
clock_t n = clock();;
/* if GetThreadTimes fails, we're probably running Windows 95 */
tp->tv_sec = (time_t)(n / CLOCKS_PER_SEC);
tp->tv_nsec = (long)((n % CLOCKS_PER_SEC) * (1000000000 / CLOCKS_PER_SEC));
break;
}
}
case time_duration:
case time_monotonic: {
LARGE_INTEGER count;
if (hires_cps == 0 && QueryPerformanceFrequency(&count))
hires_cps = count.QuadPart;
if (hires_cps && QueryPerformanceCounter(&count)) {
tp->tv_sec = (time_t)(count.QuadPart / hires_cps);
tp->tv_nsec = (long)((count.QuadPart % hires_cps) * (1000000000 / hires_cps));
break;
} else {
DWORD count = GetTickCount();
tp->tv_sec = (time_t)(count / 1000);
tp->tv_nsec = (long)((count % 1000) * 1000000);
break;
}
}
case time_utc: {
FILETIME ft; __int64 total;
s_GetSystemTimeAsFileTime(&ft);
total = ft.dwHighDateTime;
total <<= 32;
total |= ft.dwLowDateTime;
/* measurement interval is 100 nanoseconds = 1/10 microseconds */
/* adjust by number of seconds between Windows (1601) and Unix (1970) epochs */
tp->tv_sec = (time_t)(total / 10000000 - 11644473600L);
tp->tv_nsec = (long)((total % 10000000) * 100);
break;
}
default:
S_error1("S_gettime", "unexpected typeno ~s", Sinteger(typeno));
break;
}
}
static struct tm *gmtime_r(const time_t *timep, struct tm *result) {
return gmtime_s(result, timep) == 0 ? result : NULL;
}
static struct tm *localtime_r(const time_t *timep, struct tm *result) {
return localtime_s(result, timep) == 0 ? result : NULL;
}
static char *ctime_r(const time_t *timep, char *buf) {
return ctime_s(buf, 26, timep) == 0 ? buf : NULL;
}
static char *asctime_r(const struct tm *tm, char *buf) {
return asctime_s(buf, 26, tm) == 0 ? buf : NULL;
}
#else /* WIN32 */
void S_gettime(INT typeno, struct timespec *tp) {
switch (typeno) {
case time_thread:
#ifdef CLOCK_THREAD_CPUTIME_ID
if (clock_gettime(CLOCK_THREAD_CPUTIME_ID, tp) == 0) return;
#endif
/* fall through */
/* to utc case in case no thread timer */
case time_process:
#ifdef CLOCK_PROCESS_CPUTIME_ID
if (clock_gettime(CLOCK_PROCESS_CPUTIME_ID, tp) == 0) return;
#endif
/* fall back on getrusage if clock_gettime fails */
{
struct rusage rbuf;
if (getrusage(RUSAGE_SELF,&rbuf) != 0)
S_error1("S_gettime", "failed: ~s", S_strerror(errno));
tp->tv_sec = rbuf.ru_utime.tv_sec + rbuf.ru_stime.tv_sec;
tp->tv_nsec = (rbuf.ru_utime.tv_usec + rbuf.ru_stime.tv_usec) * 1000;
if (tp->tv_nsec >= 1000000000) {
tp->tv_sec += 1;
tp->tv_nsec -= 1000000000;
}
return;
}
case time_duration:
case time_monotonic:
#ifdef CLOCK_MONOTONIC_HR
if (clock_gettime(CLOCK_MONOTONIC_HR, tp) == 0) return;
#endif
#ifdef CLOCK_MONOTONIC
if (clock_gettime(CLOCK_MONOTONIC, tp) == 0) return;
#endif
#ifdef CLOCK_HIGHRES
if (clock_gettime(CLOCK_HIGHRES, tp) == 0) return;
#endif
/* fall through */
/* to utc case in case no monotonic timer */
case time_utc:
#ifdef CLOCK_REALTIME_HR
if (clock_gettime(CLOCK_REALTIME_HR, tp) == 0) return;
#endif
#ifdef CLOCK_REALTIME
if (clock_gettime(CLOCK_REALTIME, tp) == 0) return;
#endif
/* fall back on gettimeofday if clock_gettime fails */
{
struct timeval tvtp;
if (gettimeofday(&tvtp,NULL) != 0)
S_error1("S_gettime", "failed: ~s", S_strerror(errno));
tp->tv_sec = (time_t)tvtp.tv_sec;
tp->tv_nsec = (long)(tvtp.tv_usec * 1000);
return;
}
default:
S_error1("S_gettime", "unexpected typeno ~s", Sinteger(typeno));
break;
}
}
#endif /* WIN32 */
ptr S_clock_gettime(I32 typeno) {
struct timespec tp;
time_t sec; I32 nsec;
S_gettime(typeno, &tp);
sec = tp.tv_sec;
nsec = tp.tv_nsec;
if (typeno == time_monotonic || typeno == time_duration) {
sec -= starting_mono_tp.tv_sec;
nsec -= starting_mono_tp.tv_nsec;
if (nsec < 0) {
sec -= 1;
nsec += 1000000000;
}
}
return Scons(S_integer_time_t(sec), Sinteger(nsec));
}
ptr S_gmtime(ptr tzoff, ptr tspair) {
time_t tx;
struct tm tmx;
ptr dtvec = S_vector(dtvec_size);
if (tspair == Sfalse) {
struct timespec tp;
S_gettime(time_utc, &tp);
tx = tp.tv_sec;
INITVECTIT(dtvec, dtvec_nsec) = Sinteger(tp.tv_nsec);
} else {
tx = Sinteger_value(Scar(tspair));
INITVECTIT(dtvec, dtvec_nsec) = Scdr(tspair);
}
if (tzoff == Sfalse) {
if (localtime_r(&tx, &tmx) == NULL) return Sfalse;
tmx.tm_isdst = -1; /* have mktime determine the DST status */
if (mktime(&tmx) == (time_t)-1) return Sfalse;
(void) adjust_time_zone(dtvec, &tmx, Sfalse);
} else {
tx += Sinteger_value(tzoff);
if (gmtime_r(&tx, &tmx) == NULL) return Sfalse;
INITVECTIT(dtvec, dtvec_tzoff) = tzoff;
INITVECTIT(dtvec, dtvec_isdst) = Sfalse;
INITVECTIT(dtvec, dtvec_tzname) = Sfalse;
}
INITVECTIT(dtvec, dtvec_sec) = Sinteger(tmx.tm_sec);
INITVECTIT(dtvec, dtvec_min) = Sinteger(tmx.tm_min);
INITVECTIT(dtvec, dtvec_hour) = Sinteger(tmx.tm_hour);
INITVECTIT(dtvec, dtvec_mday) = Sinteger(tmx.tm_mday);
INITVECTIT(dtvec, dtvec_mon) = Sinteger(tmx.tm_mon + 1);
INITVECTIT(dtvec, dtvec_year) = Sinteger(tmx.tm_year);
INITVECTIT(dtvec, dtvec_wday) = Sinteger(tmx.tm_wday);
INITVECTIT(dtvec, dtvec_yday) = Sinteger(tmx.tm_yday);
return dtvec;
}
ptr S_asctime(ptr dtvec) {
char buf[26];
if (dtvec == Sfalse) {
time_t tx = time(NULL);
if (ctime_r(&tx, buf) == NULL) return Sfalse;
} else {
struct tm tmx;
tmx.tm_sec = (int)Sinteger_value(Svector_ref(dtvec, dtvec_sec));
tmx.tm_min = (int)Sinteger_value(Svector_ref(dtvec, dtvec_min));
tmx.tm_hour = (int)Sinteger_value(Svector_ref(dtvec, dtvec_hour));
tmx.tm_mday = (int)Sinteger_value(Svector_ref(dtvec, dtvec_mday));
tmx.tm_mon = (int)Sinteger_value(Svector_ref(dtvec, dtvec_mon)) - 1;
tmx.tm_year = (int)Sinteger_value(Svector_ref(dtvec, dtvec_year));
tmx.tm_wday = (int)Sinteger_value(Svector_ref(dtvec, dtvec_wday));
tmx.tm_yday = (int)Sinteger_value(Svector_ref(dtvec, dtvec_yday));
tmx.tm_isdst = (int)Sboolean_value(Svector_ref(dtvec, dtvec_isdst));
if (asctime_r(&tmx, buf) == NULL) return Sfalse;
}
return S_string(buf, 24) /* all but trailing newline */;
}
ptr S_mktime(ptr dtvec) {
time_t tx;
struct tm tmx;
long orig_tzoff, tzoff;
ptr given_tzoff;
tmx.tm_sec = (int)Sinteger_value(Svector_ref(dtvec, dtvec_sec));
tmx.tm_min = (int)Sinteger_value(Svector_ref(dtvec, dtvec_min));
tmx.tm_hour = (int)Sinteger_value(Svector_ref(dtvec, dtvec_hour));
tmx.tm_mday = (int)Sinteger_value(Svector_ref(dtvec, dtvec_mday));
tmx.tm_mon = (int)Sinteger_value(Svector_ref(dtvec, dtvec_mon)) - 1;
tmx.tm_year = (int)Sinteger_value(Svector_ref(dtvec, dtvec_year));
given_tzoff = INITVECTIT(dtvec, dtvec_tzoff);
if (given_tzoff == Sfalse)
orig_tzoff = 0;
else
orig_tzoff = (long)UNFIX(given_tzoff);
tmx.tm_isdst = -1; /* have mktime determine the DST status */
if ((tx = mktime(&tmx)) == (time_t)-1) return Sfalse;
/* mktime may have normalized some values, set wday and yday */
INITVECTIT(dtvec, dtvec_sec) = Sinteger(tmx.tm_sec);
INITVECTIT(dtvec, dtvec_min) = Sinteger(tmx.tm_min);
INITVECTIT(dtvec, dtvec_hour) = Sinteger(tmx.tm_hour);
INITVECTIT(dtvec, dtvec_mday) = Sinteger(tmx.tm_mday);
INITVECTIT(dtvec, dtvec_mon) = Sinteger(tmx.tm_mon + 1);
INITVECTIT(dtvec, dtvec_year) = Sinteger(tmx.tm_year);
INITVECTIT(dtvec, dtvec_wday) = Sinteger(tmx.tm_wday);
INITVECTIT(dtvec, dtvec_yday) = Sinteger(tmx.tm_yday);
tzoff = adjust_time_zone(dtvec, &tmx, given_tzoff);
if (tzoff != orig_tzoff) tx = tx - orig_tzoff + tzoff;
return Scons(S_integer_time_t(tx), Svector_ref(dtvec, dtvec_nsec));
}
static long adjust_time_zone(ptr dtvec, struct tm *tmxp, ptr given_tzoff) {
ptr tz_name = Sfalse;
long use_tzoff, tzoff;
#ifdef WIN32
{
TIME_ZONE_INFORMATION tz;
wchar_t *w_tzname;
/* The ...ForYear() function is available on Windows Vista and later: */
GetTimeZoneInformationForYear(tmxp->tm_year, NULL, &tz);
if (tmxp->tm_isdst) {
tzoff = (tz.Bias + tz.DaylightBias) * -60;
w_tzname = tz.DaylightName;
} else {
tzoff = (tz.Bias + tz.StandardBias) * -60;
w_tzname = tz.StandardName;
}
if (given_tzoff == Sfalse) {
char *name = Swide_to_utf8(w_tzname);
tz_name = Sstring_utf8(name, -1);
free(name);
}
}
#else
tzoff = tmxp->tm_gmtoff;
if (given_tzoff == Sfalse) {
# if defined(__linux__) || defined(SOLARIS)
/* Linux and Solaris set `tzname`: */
tz_name = Sstring_utf8(tzname[tmxp->tm_isdst], -1);
# else
/* BSD variants add `tm_zone` in `struct tm`: */
tz_name = Sstring_utf8(tmxp->tm_zone, -1);
# endif
}
#endif
if (given_tzoff == Sfalse)
use_tzoff = tzoff;
else
use_tzoff = (long)UNFIX(given_tzoff);
INITVECTIT(dtvec, dtvec_isdst) = ((given_tzoff == Sfalse) ? Sboolean(tmxp->tm_isdst) : Sfalse);
INITVECTIT(dtvec, dtvec_tzoff) = FIX(use_tzoff);
INITVECTIT(dtvec, dtvec_tzname) = tz_name;
return tzoff;
}
/******** old real-time and cpu-time support ********/
ptr S_cputime(void) {
struct timespec tp;
S_gettime(time_process, &tp);
return S_add(S_mul(S_integer_time_t(tp.tv_sec), FIX(1000)),
Sinteger((tp.tv_nsec + 500000) / 1000000));
}
ptr S_realtime(void) {
struct timespec tp;
time_t sec; I32 nsec;
S_gettime(time_monotonic, &tp);
sec = tp.tv_sec - starting_mono_tp.tv_sec;
nsec = tp.tv_nsec - starting_mono_tp.tv_nsec;
if (nsec < 0) {
sec -= 1;
nsec += 1000000000;
}
return S_add(S_mul(S_integer_time_t(sec), FIX(1000)),
Sinteger((nsec + 500000) / 1000000));
}
/******** initialization ********/
void S_stats_init(void) {
#ifdef WIN32
/* Use GetSystemTimePreciseAsFileTime when available (Windows 8 and later). */
HMODULE h = LoadLibraryW(L"kernel32.dll");
if (h != NULL) {
GetSystemTimeAsFileTime_t proc = (GetSystemTimeAsFileTime_t)GetProcAddress(h, "GetSystemTimePreciseAsFileTime");
if (proc != NULL)
s_GetSystemTimeAsFileTime = proc;
else
FreeLibrary(h);
}
#endif
S_gettime(time_monotonic, &starting_mono_tp);
}

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

Binary file not shown.

28
ta6ob/c/symbol.c Normal file
View file

@ -0,0 +1,28 @@
/* symbol.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"
ptr S_symbol_value(ptr sym) {
if (SYMVAL(sym) == sunbound)
S_error1("","~s is not bound", sym);
return SYMVAL(sym);
}
void S_set_symbol_value(ptr sym, ptr val) {
SETSYMVAL(sym, val);
SETSYMCODE(sym, Sprocedurep(val) ? CLOSCODE(val) : S_G.nonprocedure_code);
}

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

Binary file not shown.

47
ta6ob/c/system.h Normal file
View file

@ -0,0 +1,47 @@
/* system.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.
*/
#include "scheme.h"
#include "equates.h"
#ifdef FEATURE_WINDOWS
#ifdef __MINGW32__
# undef WINVER
# undef _WIN32_WINNT
#endif
#define WINVER 0x0601 // Windows 7
#define _WIN32_WINNT WINVER
#include <windows.h>
#endif
#include "version.h"
#include <stdio.h>
#include <stddef.h>
#include "thread.h"
#include "types.h"
#include "compress-io.h"
#ifndef EXTERN
#define EXTERN extern
#endif
#include "globals.h"
#include "externs.h"
#include "segment.h"

470
ta6ob/c/thread.c Normal file
View file

@ -0,0 +1,470 @@
/* thread.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 */
#ifdef PTHREADS
static s_thread_rv_t start_thread(void *tc);
static IBOOL destroy_thread(ptr tc);
#endif
void S_thread_init(void) {
if (S_boot_time) {
S_protect(&S_G.threadno);
S_G.threadno = FIX(0);
#ifdef PTHREADS
/* this is also reset in scheme.c after heap restoration */
s_thread_mutex_init(&S_tc_mutex.pmutex);
S_tc_mutex.owner = s_thread_self();
S_tc_mutex.count = 0;
s_thread_cond_init(&S_collect_cond);
S_tc_mutex_depth = 0;
#endif /* PTHREADS */
}
}
/* this needs to be reworked. currently, S_create_thread_object is
called from main to create the base thread, from fork_thread when
there is already an active current thread, and from S_activate_thread
when there is no current thread. we have to avoid thread-local
allocation in at least the latter case, so we call vector_in and
cons_in and arrange for S_thread to use find_room rather than
thread_find_room. scheme.c does part of the initialization of the
base thread (e.g., parameters, current input/output ports) in one
or more places. */
ptr S_create_thread_object(const char *who, ptr p_tc) {
ptr thread, tc;
INT i;
tc_mutex_acquire()
if (S_threads == Snil) {
tc = (ptr)S_G.thread_context;
} else { /* clone parent */
ptr p_v = PARAMETERS(p_tc);
iptr i, n = Svector_length(p_v);
/* use S_vector_in to avoid thread-local allocation */
ptr v = S_vector_in(space_new, 0, n);
tc = (ptr)malloc(size_tc);
if (tc == (ptr)0)
S_error(who, "unable to malloc thread data structure");
memcpy((void *)tc, (void *)p_tc, size_tc);
for (i = 0; i < n; i += 1)
INITVECTIT(v, i) = Svector_ref(p_v, i);
PARAMETERS(tc) = v;
CODERANGESTOFLUSH(tc) = Snil;
}
/* override nonclonable tc fields */
THREADNO(tc) = S_G.threadno;
S_G.threadno = S_add(S_G.threadno, FIX(1));
CCHAIN(tc) = Snil;
WINDERS(tc) = Snil;
STACKLINK(tc) = SYMVAL(S_G.null_continuation_id);
STACKCACHE(tc) = Snil;
/* S_reset_scheme_stack initializes stack, size, esp, and sfp */
S_reset_scheme_stack(tc, stack_slop);
FRAME(tc,0) = (ptr)&CODEIT(S_G.dummy_code_object,size_rp_header);
/* S_reset_allocation_pointer initializes ap and eap */
S_reset_allocation_pointer(tc);
RANDOMSEED(tc) = most_positive_fixnum < 0xffffffff ? most_positive_fixnum : 0xffffffff;
X(tc) = Y(tc) = U(tc) = V(tc) = W(tc) = FIX(0);
TIMERTICKS(tc) = Sfalse;
DISABLECOUNT(tc) = Sfixnum(0);
SIGNALINTERRUPTPENDING(tc) = Sfalse;
SIGNALINTERRUPTQUEUE(tc) = S_allocate_scheme_signal_queue();
KEYBOARDINTERRUPTPENDING(tc) = Sfalse;
TARGETMACHINE(tc) = S_intern((const unsigned char *)MACHINE_TYPE);
/* choosing not to clone virtual registers */
for (i = 0 ; i < virtual_register_count ; i += 1) {
VIRTREG(tc, i) = FIX(0);
}
DSTBV(tc) = SRCBV(tc) = Sfalse;
/* S_thread had better not do thread-local allocation */
thread = S_thread(tc);
/* use S_cons_in to avoid thread-local allocation */
S_threads = S_cons_in(space_new, 0, thread, S_threads);
S_nthreads += 1;
SETSYMVAL(S_G.active_threads_id,
FIX(UNFIX(SYMVAL(S_G.active_threads_id)) + 1));
ACTIVE(tc) = 1;
/* collect request is only thing that can be pending for new thread.
must do this after we're on the thread list in case the cons
adding us onto the thread list set collect-request-pending */
SOMETHINGPENDING(tc) = SYMVAL(S_G.collect_request_pending_id);
GUARDIANENTRIES(tc) = Snil;
LZ4OUTBUFFER(tc) = NULL;
tc_mutex_release()
return thread;
}
#ifdef PTHREADS
IBOOL Sactivate_thread(void) { /* create or reactivate current thread */
ptr tc = get_thread_context();
if (tc == (ptr)0) { /* thread created by someone else */
ptr thread;
/* borrow base thread for now */
thread = S_create_thread_object("Sactivate_thread", S_G.thread_context);
s_thread_setspecific(S_tc_key, (ptr)THREADTC(thread));
return 1;
} else {
reactivate_thread(tc)
return 0;
}
}
int S_activate_thread(void) { /* Like Sactivate_thread(), but returns a mode to revert the effect */
ptr tc = get_thread_context();
if (tc == (ptr)0) {
Sactivate_thread();
return unactivate_mode_destroy;
} else if (!ACTIVE(tc)) {
reactivate_thread(tc);
return unactivate_mode_deactivate;
} else
return unactivate_mode_noop;
}
void S_unactivate_thread(int mode) { /* Reverts a previous S_activate_thread() effect */
switch (mode) {
case unactivate_mode_deactivate:
Sdeactivate_thread();
break;
case unactivate_mode_destroy:
Sdestroy_thread();
break;
case unactivate_mode_noop:
default:
break;
}
}
void Sdeactivate_thread(void) { /* deactivate current thread */
ptr tc = get_thread_context();
if (tc != (ptr)0) deactivate_thread(tc)
}
int Sdestroy_thread(void) { /* destroy current thread */
ptr tc = get_thread_context();
if (tc != (ptr)0 && destroy_thread(tc)) {
s_thread_setspecific(S_tc_key, 0);
return 1;
}
return 0;
}
static IBOOL destroy_thread(ptr tc) {
ptr *ls; IBOOL status;
status = 0;
tc_mutex_acquire()
ls = &S_threads;
while (*ls != Snil) {
ptr thread = Scar(*ls);
if (THREADTC(thread) == (uptr)tc) {
*ls = Scdr(*ls);
S_nthreads -= 1;
/* process remembered set before dropping allocation area */
S_scan_dirty((ptr **)EAP(tc), (ptr **)REAL_EAP(tc));
/* process guardian entries */
{
ptr target, ges, obj, next; seginfo *si;
target = S_G.guardians[0];
for (ges = GUARDIANENTRIES(tc); ges != Snil; ges = next) {
obj = GUARDIANOBJ(ges);
next = GUARDIANNEXT(ges);
if (!IMMEDIATE(obj) && (si = MaybeSegInfo(ptr_get_segment(obj))) != NULL && si->generation != static_generation) {
INITGUARDIANNEXT(ges) = target;
target = ges;
}
}
S_G.guardians[0] = target;
}
/* deactivate thread */
if (ACTIVE(tc)) {
SETSYMVAL(S_G.active_threads_id,
FIX(UNFIX(SYMVAL(S_G.active_threads_id)) - 1));
if (Sboolean_value(SYMVAL(S_G.collect_request_pending_id))
&& SYMVAL(S_G.active_threads_id) == FIX(0)) {
s_thread_cond_signal(&S_collect_cond);
}
}
if (LZ4OUTBUFFER(tc) != NULL) free(LZ4OUTBUFFER(tc));
if (SIGNALINTERRUPTQUEUE(tc) != NULL) free(SIGNALINTERRUPTQUEUE(tc));
free((void *)tc);
THREADTC(thread) = 0; /* mark it dead */
status = 1;
break;
}
ls = &Scdr(*ls);
}
tc_mutex_release()
return status;
}
ptr S_fork_thread(ptr thunk) {
ptr thread;
int status;
/* pass the current thread's context as the parent thread */
thread = S_create_thread_object("fork-thread", get_thread_context());
CP(THREADTC(thread)) = thunk;
if ((status = s_thread_create(start_thread, (void *)THREADTC(thread))) != 0) {
destroy_thread((ptr)THREADTC(thread));
S_error1("fork-thread", "failed: ~a", S_strerror(status));
}
return thread;
}
static s_thread_rv_t start_thread(p) void *p; {
ptr tc = (ptr)p; ptr cp;
s_thread_setspecific(S_tc_key, tc);
cp = CP(tc);
CP(tc) = Svoid; /* should hold calling code object, which we don't have */
TRAP(tc) = (ptr)default_timer_ticks;
Scall0(cp);
/* caution: calling into Scheme may result into a collection, so we
can't access any Scheme objects, e.g., cp, after this point. But tc
is static, so we can access it. */
/* find and destroy our thread */
destroy_thread(tc);
s_thread_setspecific(S_tc_key, (ptr)0);
s_thread_return;
}
scheme_mutex_t *S_make_mutex() {
scheme_mutex_t *m;
m = (scheme_mutex_t *)malloc(sizeof(scheme_mutex_t));
if (m == (scheme_mutex_t *)0)
S_error("make-mutex", "unable to malloc mutex");
s_thread_mutex_init(&m->pmutex);
m->owner = s_thread_self();
m->count = 0;
return m;
}
void S_mutex_free(scheme_mutex_t *m) {
s_thread_mutex_destroy(&m->pmutex);
free(m);
}
void S_mutex_acquire(scheme_mutex_t *m) {
s_thread_t self = s_thread_self();
iptr count;
INT status;
if ((count = m->count) > 0 && s_thread_equal(m->owner, self)) {
if (count == most_positive_fixnum)
S_error1("mutex-acquire", "recursion limit exceeded for ~s", m);
m->count = count + 1;
return;
}
if ((status = s_thread_mutex_lock(&m->pmutex)) != 0)
S_error1("mutex-acquire", "failed: ~a", S_strerror(status));
m->owner = self;
m->count = 1;
}
INT S_mutex_tryacquire(scheme_mutex_t *m) {
s_thread_t self = s_thread_self();
iptr count;
INT status;
if ((count = m->count) > 0 && s_thread_equal(m->owner, self)) {
if (count == most_positive_fixnum)
S_error1("mutex-acquire", "recursion limit exceeded for ~s", m);
m->count = count + 1;
return 0;
}
status = s_thread_mutex_trylock(&m->pmutex);
if (status == 0) {
m->owner = self;
m->count = 1;
} else if (status != EBUSY) {
S_error1("mutex-acquire", "failed: ~a", S_strerror(status));
}
return status;
}
void S_mutex_release(scheme_mutex_t *m) {
s_thread_t self = s_thread_self();
iptr count;
INT status;
if ((count = m->count) == 0 || !s_thread_equal(m->owner, self))
S_error1("mutex-release", "thread does not own mutex ~s", m);
if ((m->count = count - 1) == 0)
if ((status = s_thread_mutex_unlock(&m->pmutex)) != 0)
S_error1("mutex-release", "failed: ~a", S_strerror(status));
}
s_thread_cond_t *S_make_condition() {
s_thread_cond_t *c;
c = (s_thread_cond_t *)malloc(sizeof(s_thread_cond_t));
if (c == (s_thread_cond_t *)0)
S_error("make-condition", "unable to malloc condition");
s_thread_cond_init(c);
return c;
}
void S_condition_free(s_thread_cond_t *c) {
s_thread_cond_destroy(c);
free(c);
}
#ifdef FEATURE_WINDOWS
static inline int s_thread_cond_timedwait(s_thread_cond_t *cond, s_thread_mutex_t *mutex, int typeno, I64 sec, long nsec) {
if (typeno == time_utc) {
struct timespec now;
S_gettime(time_utc, &now);
sec -= now.tv_sec;
nsec -= now.tv_nsec;
if (nsec < 0) {
sec -= 1;
nsec += 1000000000;
}
}
if (sec < 0) {
sec = 0;
nsec = 0;
}
if (SleepConditionVariableCS(cond, mutex, (DWORD)(sec*1000 + (nsec+500000)/1000000))) {
return 0;
} else if (GetLastError() == ERROR_TIMEOUT) {
return ETIMEDOUT;
} else {
return EINVAL;
}
}
#else /* FEATURE_WINDOWS */
static inline int s_thread_cond_timedwait(s_thread_cond_t *cond, s_thread_mutex_t *mutex, int typeno, I64 sec, long nsec) {
struct timespec t;
if (typeno == time_duration) {
struct timespec now;
S_gettime(time_utc, &now);
t.tv_sec = (time_t)(now.tv_sec + sec);
t.tv_nsec = now.tv_nsec + nsec;
if (t.tv_nsec >= 1000000000) {
t.tv_sec += 1;
t.tv_nsec -= 1000000000;
}
} else {
t.tv_sec = sec;
t.tv_nsec = nsec;
}
return pthread_cond_timedwait(cond, mutex, &t);
}
#endif /* FEATURE_WINDOWS */
#define Srecord_ref(x,i) (((ptr *)((uptr)(x)+record_data_disp))[i])
IBOOL S_condition_wait(s_thread_cond_t *c, scheme_mutex_t *m, ptr t) {
ptr tc = get_thread_context();
s_thread_t self = s_thread_self();
iptr count;
INT typeno;
I64 sec;
long nsec;
INT status;
if ((count = m->count) == 0 || !s_thread_equal(m->owner, self))
S_error1("condition-wait", "thread does not own mutex ~s", m);
if (count != 1)
S_error1("condition-wait", "mutex ~s is recursively locked", m);
if (t != Sfalse) {
/* Keep in sync with ts record in s/date.ss */
typeno = Sinteger32_value(Srecord_ref(t,0));
sec = Sinteger64_value(Scar(Srecord_ref(t,1)));
nsec = Sinteger32_value(Scdr(Srecord_ref(t,1)));
} else {
typeno = 0;
sec = 0;
nsec = 0;
}
if (c == &S_collect_cond || DISABLECOUNT(tc) == 0) {
deactivate_thread(tc)
}
m->count = 0;
status = (t == Sfalse) ? s_thread_cond_wait(c, &m->pmutex) :
s_thread_cond_timedwait(c, &m->pmutex, typeno, sec, nsec);
m->owner = self;
m->count = 1;
if (c == &S_collect_cond || DISABLECOUNT(tc) == 0) {
reactivate_thread(tc)
}
if (status == 0) {
return 1;
} else if (status == ETIMEDOUT) {
return 0;
} else {
S_error1("condition-wait", "failed: ~a", S_strerror(status));
return 0;
}
}
#endif /* PTHREADS */

91
ta6ob/c/thread.h Normal file
View file

@ -0,0 +1,91 @@
/* thread.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.
*/
#ifdef FEATURE_PTHREADS
#ifdef FEATURE_WINDOWS
#include <process.h>
#include <time.h>
/* learned from http://locklessinc.com/articles/pthreads_on_windows/ which
* Windows API types and functions to use to support mutexes and condition
* variables. there's much more information there if we ever need a more
* complete implementation of pthreads functionality.
*/
typedef DWORD s_thread_t;
typedef DWORD s_thread_key_t;
typedef CRITICAL_SECTION s_thread_mutex_t;
typedef CONDITION_VARIABLE s_thread_cond_t;
typedef void s_thread_rv_t;
#define s_thread_return return
#define s_thread_self() GetCurrentThreadId()
#define s_thread_equal(t1, t2) ((t1) == (t2))
/* CreateThread description says to use _beginthread if thread uses the C library */
#define s_thread_create(start_routine, arg) (_beginthread(start_routine, 0, arg) == -1 ? EAGAIN : 0)
#define s_thread_key_create(key) ((*key = TlsAlloc()) == TLS_OUT_OF_INDEXES ? EAGAIN : 0)
#define s_thread_key_delete(key) (TlsFree(key) == 0 ? EINVAL : 0)
#define s_thread_getspecific(key) TlsGetValue(key)
#define s_thread_setspecific(key, value) (TlsSetValue(key, (void *)value) == 0 ? EINVAL : 0)
#define s_thread_mutex_init(mutex) InitializeCriticalSection(mutex)
#define s_thread_mutex_lock(mutex) (EnterCriticalSection(mutex), 0)
#define s_thread_mutex_unlock(mutex) (LeaveCriticalSection(mutex), 0)
#define s_thread_mutex_trylock(mutex) (TryEnterCriticalSection(mutex) ? 0 : EBUSY)
#define s_thread_mutex_destroy(mutex) (DeleteCriticalSection(mutex), 0)
#define s_thread_cond_init(cond) InitializeConditionVariable(cond)
#define s_thread_cond_signal(cond) (WakeConditionVariable(cond), 0)
#define s_thread_cond_broadcast(cond) (WakeAllConditionVariable(cond), 0)
#define s_thread_cond_wait(cond, mutex) (SleepConditionVariableCS(cond, mutex, INFINITE) == 0 ? EINVAL : 0)
#define s_thread_cond_destroy(cond) (0)
#else /* FEATURE_WINDOWS */
#include <pthread.h>
typedef pthread_t s_thread_t;
typedef pthread_key_t s_thread_key_t;
typedef pthread_mutex_t s_thread_mutex_t;
typedef pthread_cond_t s_thread_cond_t;
typedef void *s_thread_rv_t;
#define s_thread_return return NULL
#define s_thread_self() pthread_self()
#define s_thread_equal(t1, t2) pthread_equal(t1, t2)
static inline int s_thread_create(void *(* start_routine)(void *), void *arg) {
pthread_attr_t attr; pthread_t thread; int status;
pthread_attr_init(&attr);
pthread_attr_setdetachstate(&attr, PTHREAD_CREATE_DETACHED);
status = pthread_create(&thread, &attr, start_routine, arg);
pthread_attr_destroy(&attr);
return status;
}
#define s_thread_key_create(key) pthread_key_create(key, NULL)
#define s_thread_key_delete(key) pthread_key_delete(key)
#define s_thread_getspecific(key) pthread_getspecific(key)
#define s_thread_setspecific(key, value) pthread_setspecific(key, value)
#define s_thread_mutex_init(mutex) pthread_mutex_init(mutex, NULL)
#define s_thread_mutex_lock(mutex) pthread_mutex_lock(mutex)
#define s_thread_mutex_unlock(mutex) pthread_mutex_unlock(mutex)
#define s_thread_mutex_trylock(mutex) pthread_mutex_trylock(mutex)
#define s_thread_mutex_destroy(mutex) pthread_mutex_destroy(mutex)
#define s_thread_cond_init(cond) pthread_cond_init(cond, NULL)
#define s_thread_cond_signal(cond) pthread_cond_signal(cond)
#define s_thread_cond_broadcast(cond) pthread_cond_broadcast(cond)
#define s_thread_cond_wait(cond, mutex) pthread_cond_wait(cond, mutex)
#define s_thread_cond_destroy(cond) pthread_cond_destroy(cond)
#endif /* FEATURE_WINDOWS */
#endif /* FEATURE_PTHREADS */

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

Binary file not shown.

381
ta6ob/c/types.h Normal file
View file

@ -0,0 +1,381 @@
/* types.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.
*/
/* C datatypes (mostly defined in equates.h or scheme.h)
* ptr: scheme object: (void *) on most platforms
* uptr: unsigned integer sizeof(uptr) == sizeof(ptr): typically unsigned long
* iptr: signed integer sizeof(uptr) == sizeof(ptr): typically long
* I8: 8-bit signed integer: typically char
* I16: 16-bit signed integer: typically short
* I32: 32-bit signed integer: typically int
* U32: 32-bit unsigned integer: typically unsigned int
* I64: 64-bit signed integer: typically long long
* U64: 64-bit unsigned integer: typically unsigned long long
* bigit: unsigned integer sizeof(bigit)*8 == bigit_bits
* bigit: unsigned integer sizeof(bigit)*8 == bigit_bits
*/
#if (bigit_bits == 32)
typedef U32 bigit;
typedef U64 bigitbigit;
typedef I32 ibigit;
typedef I64 ibigitbigit;
#endif
/* C signed/unsigned conventions:
* signed/unsigned distinction is felt in comparisons with zero, right
* shifts, multiplies, and divides.
*
* general philosophy is to avoid surprises by using signed quantities,
* with a few exceptions.
*
* use unsigned whenever shifting right. ANSI C >> is undefined for
* negative numbers. if arithmetic shift is desired, divide by the
* appropriate power of two and hope that the C compiler generates a
* shift instruction.
*
* cast to uptr for ptr address computations. this is really necessary
* only when shifting addresses, but we do it all the time since
* addresses are inherently unsigned values.
*
* however, use signed (usually iptr) for lengths and array indices.
* this allows base cases like i < 0 when working backward from the end
* to the front of an array. using uptr would give a slightly larger
* range in theory, but not in practice.
*/
/* documentary names for ints and unsigned ints */
typedef int INT; /* honest-to-goodness C int */
typedef unsigned int UINT; /* honest-to-goodness C unsigned int */
typedef int ITYPE; /* ptr types */
typedef int ISPC; /* storage manager spaces */
typedef int IGEN; /* storage manager generations */
typedef int IDIRTYBYTE; /* storage manager dirty bytes */
typedef int IBOOL; /* int used exclusively as a boolean */
typedef int ICHAR; /* int used exclusively as a character */
typedef int IFASLCODE; /* fasl type codes */
#if (BUFSIZ < 4096)
#define SBUFSIZ 4096
#else
#define SBUFSIZ BUFSIZ
#endif
/* inline allocation --- mutex required */
/* find room allocates n bytes in space s and generation g into
* destination x, tagged with ty, punting to find_more_room if
* no space is left in the current segment. n is assumed to be
* an integral multiple of the object alignment. */
#define find_room(s, g, t, n, x) {\
ptr X = S_G.next_loc[g][s];\
S_G.next_loc[g][s] = (ptr)((uptr)X + (n));\
if ((S_G.bytes_left[g][s] -= (n)) < 0) X = S_find_more_room(s, g, n, X);\
(x) = TYPE(X, t);\
}
/* thread-local inline allocation --- no mutex required */
/* thread_find_room allocates n bytes in the local allocation area of
* the thread (hence space new, generation zero) into destination x, tagged
* with type t, punting to find_more_room if no space is left in the current
* allocation area. n is assumed to be an integral multiple of the object
* alignment. */
#define thread_find_room(tc, t, n, x) {\
ptr _tc = tc;\
uptr _ap = (uptr)AP(_tc);\
if ((uptr)n > ((uptr)EAP(_tc) - _ap)) {\
(x) = S_get_more_room_help(_tc, _ap, t, n);\
} else {\
(x) = TYPE(_ap,t);\
AP(_tc) = (ptr)(_ap + n);\
}\
}
/* size of protected array used to store roots for the garbage collector */
#define max_protected 100
#define build_ptr(s,o) ((ptr)(((uptr)(s) << segment_offset_bits) | (uptr)(o)))
#define addr_get_segment(p) ((uptr)(p) >> segment_offset_bits)
#define ptr_get_segment(p) (((uptr)(p) + typemod - 1) >> segment_offset_bits)
#define SPACE(p) SegmentSpace(ptr_get_segment(p))
#define GENERATION(p) SegmentGeneration(ptr_get_segment(p))
#define ptr_align(size) (((size)+byte_alignment-1) & ~(byte_alignment-1))
typedef struct _seginfo {
unsigned char space; /* space the segment is in */
unsigned char generation; /* generation the segment is in */
unsigned char sorted; /* sorted indicator---possibly to be incorporated into space flags? */
octet min_dirty_byte; /* dirty byte for full segment, effectively min(dirty_bytes) */
uptr number; /* the segment number */
struct _chunkinfo *chunk; /* the chunk this segment belongs to */
struct _seginfo *next; /* pointer to the next seginfo (used in occupied_segments and unused_segs */
struct _seginfo **dirty_prev; /* pointer to the next pointer on the previous seginfo in the DirtySegments list */
struct _seginfo *dirty_next; /* pointer to the next seginfo on the DirtySegments list */
ptr trigger_ephemerons; /* ephemerons to re-check if object in segment is copied out */
octet dirty_bytes[cards_per_segment]; /* one dirty byte per card */
} seginfo;
typedef struct _chunkinfo {
void *addr; /* chunk starting address */
iptr base; /* first segment */
iptr bytes; /* size in bytes */
iptr segs; /* size in segments */
iptr nused_segs; /* number of segments currently in used use */
struct _chunkinfo **prev; /* pointer to previous chunk's next */
struct _chunkinfo *next; /* next chunk */
struct _seginfo *unused_segs; /* list of unused segments */
struct _seginfo sis[0]; /* one seginfo per segment */
} chunkinfo;
#ifdef segment_t2_bits
typedef struct _t1table {
seginfo *t1[1<<segment_t1_bits]; /* table first to reduce access cost */
iptr refcount; /* refcount last, since it's rarely accessed */
} t1table;
#ifdef segment_t3_bits
typedef struct _t2table {
t1table *t2[1<<segment_t2_bits]; /* table first to reduce access cost */
iptr refcount; /* refcount last, since it's rarely accessed */
} t2table;
#endif /* segment_t3_bits */
#endif /* segment_t2_bits */
/* CHUNK_POOLS determines the number of bins into which find_segment sorts chunks with
varying lengths of empty segment chains. it must be at least 1. */
#define PARTIAL_CHUNK_POOLS 8
/* dirty list table is conceptually a two-dimensional gen x gen table,
but we use only the to_g entries for 0..from_g - 1. say
static_generation were 5 instead of 255, we don't need the 'X'
entries in the table below, and they would clutter up our cache lines:
to_g
0 1 2 3 4 5
+-----+-----+-----+-----+-----+-----+
0 | X | X | X | X | X | X |
+-----+-----+-----+-----+-----+-----+
1 | | X | X | X | X | X |
+-----+-----+-----+-----+-----+-----+
2 | | | X | X | X | X |
+-----+-----+-----+-----+-----+-----+
3 | | | | X | X | X |
+-----+-----+-----+-----+-----+-----+
4 | | | | | X | X |
+-----+-----+-----+-----+-----+-----+
5 | | | | | | X |
+-----+-----+-----+-----+-----+-----+
so we create a vector instead of a matrix and roll our own version
of row-major order.
+-----+-----+-----+-----+----
| 1,0 | 2,0 | 2,1 | 3,0 | ...
+-----+-----+-----+-----+----
any entry from_g, to_g can be found at from_g*(from_g-1)/2+to_g.
*/
#define DIRTY_SEGMENT_INDEX(from_g, to_g) ((((unsigned)((from_g)*((from_g)-1)))>>1)+to_g)
#define DIRTY_SEGMENT_LISTS DIRTY_SEGMENT_INDEX(static_generation, static_generation)
#define DirtySegments(from_g, to_g) S_G.dirty_segments[DIRTY_SEGMENT_INDEX(from_g, to_g)]
/* oblist */
typedef struct _bucket {
ptr sym;
struct _bucket *next;
} bucket;
typedef struct _bucket_list {
struct _bucket *car;
struct _bucket_list *cdr;
} bucket_list;
typedef struct _bucket_pointer_list {
struct _bucket **car;
struct _bucket_pointer_list *cdr;
} bucket_pointer_list;
/* size macros for variable-sized objects */
#define size_vector(n) ptr_align(header_size_vector + (n)*ptr_bytes)
#define size_closure(n) ptr_align(header_size_closure + (n)*ptr_bytes)
#define size_string(n) ptr_align(header_size_string + (n)*string_char_bytes)
#define size_fxvector(n) ptr_align(header_size_fxvector + (n)*ptr_bytes)
#define size_bytevector(n) ptr_align(header_size_bytevector + (n))
#define size_bignum(n) ptr_align(header_size_bignum + (n)*bigit_bytes)
#define size_code(n) ptr_align(header_size_code + (n))
#define size_reloc_table(n) ptr_align(header_size_reloc_table + (n)*ptr_bytes)
#define size_record_inst(n) ptr_align(n)
#define unaligned_size_record_inst(n) (n)
/* type tagging macros */
#define TYPE(x,type) ((ptr)((iptr)(x) - typemod + (type)))
#define UNTYPE(x,type) ((ptr)((iptr)(x) + typemod - (type)))
#define UNTYPE_ANY(x) ((ptr)(((iptr)(x) + (typemod - 1)) & ~(typemod - 1)))
#define TYPEBITS(x) ((iptr)(x) & (typemod - 1))
#define TYPEFIELD(x) (*(ptr *)UNTYPE(x, type_typed_object))
#define FIX(x) Sfixnum(x)
#define UNFIX(x) Sfixnum_value(x)
#define TYPEP(x,mask,type) (((iptr)(x) & (mask)) == (type))
/* reloc fields */
#define RELOC_EXTENDED_FORMAT(x) ((x)&reloc_extended_format)
#define RELOC_TYPE(x) (((x)>>reloc_type_offset)&reloc_type_mask)
#define RELOC_CODE_OFFSET(x) (((x)>>reloc_code_offset_offset)&reloc_code_offset_mask)
#define RELOC_ITEM_OFFSET(x) (((x)>>reloc_item_offset_offset)&reloc_item_offset_mask)
#define MAKE_SHORT_RELOC(ty,co,io) (((ty)<<reloc_type_offset)|((co)<<reloc_code_offset_offset)|((io)<<reloc_item_offset_offset))
/* derived type predicates */
#define GENSYMP(x) (Ssymbolp(x) && (!Sstringp(SYMNAME(x))))
#define FIXRANGE(x) ((uptr)((x) - most_negative_fixnum) <= (uptr)(most_positive_fixnum - most_negative_fixnum))
/* this breaks gcc 2.96
#define FIXRANGE(x) (Sfixnum_value(Sfixnum(x)) == x)
*/
#define DIRTYSET(lhs,rhs) S_dirty_set(lhs, rhs);
/* derived accessors/constructors */
#define FWDMARKER(p) FORWARDMARKER((uptr)UNTYPE_ANY(p))
#define FWDADDRESS(p) FORWARDADDRESS((uptr)UNTYPE_ANY(p))
#define ENTRYFRAMESIZE(x) RPHEADERFRAMESIZE((uptr)(x) - size_rp_header)
#define ENTRYOFFSET(x) RPHEADERTOPLINK((uptr)(x) - size_rp_header)
#define ENTRYLIVEMASK(x) RPHEADERLIVEMASK((uptr)(x) - size_rp_header)
#define PORTFD(x) ((iptr)PORTHANDLER(x))
#define PORTGZFILE(x) ((gzFile)(PORTHANDLER(x)))
#define CAAR(x) Scar(Scar(x))
#define CADR(x) Scar(Scdr(x))
#define CDAR(x) Scdr(Scar(x))
#define LIST1(x) Scons(x, Snil)
#define LIST2(x,y) Scons(x, LIST1(y))
#define LIST3(x,y,z) Scons(x, LIST2(y, z))
#define LIST4(x,y,z,w) Scons(x, LIST3(y, z, w))
#define REGARG(tc,i) ARGREG(tc,(i)-1)
#define FRAME(tc,i) (((ptr *)SFP(tc))[i])
#ifdef PTHREADS
typedef struct {
volatile s_thread_t owner;
volatile uptr count;
s_thread_mutex_t pmutex;
} scheme_mutex_t;
#define get_thread_context() (ptr)s_thread_getspecific(S_tc_key)
/* deactivate thread prepares the thread for a possible collection.
if it's the last active thread, it signals one of the threads
waiting on the collect condition, if any, so that a collection
can proceed. if we happen to be the collecting thread, the active
thread count is zero, in which case we don't signal. collection
is not permitted to happen when interrupts are disabled, so we
don't let anything happen in that case. */
#define deactivate_thread(tc) {\
if (ACTIVE(tc)) {\
ptr code;\
tc_mutex_acquire()\
code = CP(tc);\
if (Sprocedurep(code)) CP(tc) = code = CLOSCODE(code);\
Slock_object(code);\
SETSYMVAL(S_G.active_threads_id,\
FIX(UNFIX(SYMVAL(S_G.active_threads_id)) - 1));\
if (Sboolean_value(SYMVAL(S_G.collect_request_pending_id))\
&& SYMVAL(S_G.active_threads_id) == FIX(0)) {\
s_thread_cond_signal(&S_collect_cond);\
}\
ACTIVE(tc) = 0;\
tc_mutex_release()\
}\
}
#define reactivate_thread(tc) {\
if (!ACTIVE(tc)) {\
tc_mutex_acquire()\
SETSYMVAL(S_G.active_threads_id,\
FIX(UNFIX(SYMVAL(S_G.active_threads_id)) + 1));\
Sunlock_object(CP(tc));\
ACTIVE(tc) = 1;\
tc_mutex_release()\
}\
}
/* S_tc_mutex_depth records the number of nested mutex acquires in
C code on tc_mutex. it is used by do_error to release tc_mutex
the appropriate number of times.
*/
#define tc_mutex_acquire() {\
S_mutex_acquire(&S_tc_mutex);\
S_tc_mutex_depth += 1;\
}
#define tc_mutex_release() {\
S_tc_mutex_depth -= 1;\
S_mutex_release(&S_tc_mutex);\
}
#else
#define get_thread_context() (ptr)S_G.thread_context
#define deactivate_thread(tc) {}
#define reactivate_thread(tc) {}
#define tc_mutex_acquire() {}
#define tc_mutex_release() {}
#endif
#ifdef __MINGW32__
/* With MinGW on 64-bit Windows, setjmp/longjmp is not reliable. Using
__builtin_setjmp/__builtin_longjmp is reliable, but
__builtin_longjmp requires 1 as its second argument. So, allocate
room in the buffer for a return value. */
# define JMPBUF_RET(jb) (*(int *)((char *)(jb)+sizeof(jmp_buf)))
# define CREATEJMPBUF() malloc(sizeof(jmp_buf)+sizeof(int))
# define FREEJMPBUF(jb) free(jb)
# define SETJMP(jb) (JMPBUF_RET(jb) = 0, __builtin_setjmp(jb), JMPBUF_RET(jb))
# define LONGJMP(jb,n) (JMPBUF_RET(jb) = n, __builtin_longjmp(jb, 1))
#else
# ifdef _WIN64
# define CREATEJMPBUF() malloc(256)
# define SETJMP(jb) S_setjmp(jb)
# define LONGJMP(jb,n) S_longjmp(jb, n)
# else
/* assuming malloc will give us required alignment */
# define CREATEJMPBUF() malloc(sizeof(jmp_buf))
# define SETJMP(jb) _setjmp(jb)
# define LONGJMP(jb,n) _longjmp(jb, n)
# endif
# define FREEJMPBUF(jb) free(jb)
#endif
#define DOUNDERFLOW\
&CODEIT(CLOSCODE(S_lookup_library_entry(library_dounderflow, 1)),size_rp_header)
#define HEAP_VERSION_LENGTH 16
#define HEAP_MACHID_LENGTH 16
#define HEAP_STAMP_LENGTH 16
/* keep MAKE_FD in sync with io.ss make-fd */
#define MAKE_FD(fd) Sinteger(fd)
#define GET_FD(file) ((INT)Sinteger_value(file))
#define PTRFIELD(x,disp) (*(ptr *)((uptr)(x)+disp))
#define INITPTRFIELD(x,disp) (*(ptr *)((uptr)(x)+disp))
#define SETPTRFIELD(x,disp,y) DIRTYSET(((ptr *)((uptr)(x)+disp)),(y))
#define INCRGEN(g) (g = g == S_G.max_nonstatic_generation ? static_generation : g+1)
#define IMMEDIATE(x) (Sfixnump(x) || Simmediatep(x))

457
ta6ob/c/version.h Normal file
View file

@ -0,0 +1,457 @@
/* version.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.
*/
#include "config.h"
#if (machine_type == machine_type_arm32le || machine_type == machine_type_tarm32le || machine_type == machine_type_arm64le || machine_type == machine_type_tarm64le)
#if (machine_type == machine_type_tarm32le || machine_type == machine_type_tarm64le)
#define PTHREADS
#endif
#define NOBLOCK O_NONBLOCK
#define LOAD_SHARED_OBJECT
#define USE_MMAP
#define MMAP_HEAP
#define IEEE_DOUBLE
#define LITTLE_ENDIAN_IEEE_DOUBLE
#define LDEXP
#define ARCHYPERBOLIC
#define GETPAGESIZE() getpagesize()
typedef char *memcpy_t;
#define MAKE_NAN(x) { x = 0.0; x = x / x; }
#define GETWD(x) getcwd((x),PATH_MAX)
typedef int tputsputcchar;
#define LOCKF
#define DIRMARKERP(c) ((c) == '/')
#define FLUSHCACHE
#ifndef DISABLE_X11
#define LIBX11 "libX11.so"
#endif
#define LSEEK lseek64
#define OFF_T off64_t
#define _LARGEFILE64_SOURCE
#define SECATIME(sb) (sb).st_atim.tv_sec
#define SECCTIME(sb) (sb).st_ctim.tv_sec
#define SECMTIME(sb) (sb).st_mtim.tv_sec
#define NSECATIME(sb) (sb).st_atim.tv_nsec
#define NSECCTIME(sb) (sb).st_ctim.tv_nsec
#define NSECMTIME(sb) (sb).st_mtim.tv_nsec
#define ICONV_INBUF_TYPE char **
#define UNUSED __attribute__((__unused__))
#endif
#if (machine_type == machine_type_ppc32le || machine_type == machine_type_tppc32le || machine_type == machine_type_ppc64le || machine_type == machine_type_tppc64le)
#if (machine_type == machine_type_tppc32le || machine_type == machine_type_tppc64le)
#define PTHREADS
#endif
#define NOBLOCK O_NONBLOCK
#define LOAD_SHARED_OBJECT
#define USE_MMAP
#define MMAP_HEAP
#define IEEE_DOUBLE
#define LDEXP
#define ARCHYPERBOLIC
#define GETPAGESIZE() getpagesize()
typedef char *memcpy_t;
#define MAKE_NAN(x) { x = 0.0; x = x / x; }
#define GETWD(x) getcwd((x),PATH_MAX)
typedef int tputsputcchar;
#define LOCKF
#define DIRMARKERP(c) ((c) == '/')
#define FLUSHCACHE
#ifndef DISABLE_X11
#define LIBX11 "libX11.so"
#endif
#define LSEEK lseek64
#define OFF_T off64_t
#define _LARGEFILE64_SOURCE
#define SECATIME(sb) (sb).st_atim.tv_sec
#define SECCTIME(sb) (sb).st_ctim.tv_sec
#define SECMTIME(sb) (sb).st_mtim.tv_sec
#define NSECATIME(sb) (sb).st_atim.tv_nsec
#define NSECCTIME(sb) (sb).st_ctim.tv_nsec
#define NSECMTIME(sb) (sb).st_mtim.tv_nsec
#define ICONV_INBUF_TYPE char **
#define UNUSED __attribute__((__unused__))
#endif
#if (machine_type == machine_type_i3le || machine_type == machine_type_ti3le || machine_type == machine_type_a6le || machine_type == machine_type_ta6le)
#if (machine_type == machine_type_ti3le || machine_type == machine_type_ta6le)
#define PTHREADS
#endif
#define NOBLOCK O_NONBLOCK
#define LOAD_SHARED_OBJECT
#define USE_MMAP
#define MMAP_HEAP
#define IEEE_DOUBLE
#define LITTLE_ENDIAN_IEEE_DOUBLE
#define LDEXP
#define ARCHYPERBOLIC
#define GETPAGESIZE() getpagesize()
typedef char *memcpy_t;
#define MAKE_NAN(x) { x = 0.0; x = x / x; }
#define GETWD(x) getcwd((x),PATH_MAX)
typedef int tputsputcchar;
#define LOCKF
#define DIRMARKERP(c) ((c) == '/')
#ifndef DISABLE_X11
#define LIBX11 "libX11.so"
#endif
#define LSEEK lseek64
#define OFF_T off64_t
#define _LARGEFILE64_SOURCE
#define SECATIME(sb) (sb).st_atim.tv_sec
#define SECCTIME(sb) (sb).st_ctim.tv_sec
#define SECMTIME(sb) (sb).st_mtim.tv_sec
#define NSECATIME(sb) (sb).st_atim.tv_nsec
#define NSECCTIME(sb) (sb).st_ctim.tv_nsec
#define NSECMTIME(sb) (sb).st_mtim.tv_nsec
#define ICONV_INBUF_TYPE char **
#define UNUSED __attribute__((__unused__))
#endif
#if (machine_type == machine_type_i3fb || machine_type == machine_type_ti3fb || machine_type == machine_type_a6fb || machine_type == machine_type_ta6fb)
#if (machine_type == machine_type_ti3fb || machine_type == machine_type_ta6fb)
#define PTHREADS
#endif
#define NOBLOCK O_NONBLOCK
#define LOAD_SHARED_OBJECT
#define USE_MMAP
#define MMAP_HEAP
#define IEEE_DOUBLE
#define LITTLE_ENDIAN_IEEE_DOUBLE
#define LDEXP
#define ARCHYPERBOLIC
#define GETPAGESIZE() getpagesize()
typedef char *memcpy_t;
#define MAKE_NAN(x) { x = 0.0; x = x / x; }
#define GETWD(x) getcwd((x),PATH_MAX)
typedef int tputsputcchar;
#define LOCKF
#define DIRMARKERP(c) ((c) == '/')
#ifndef DISABLE_X11
#define LIBX11 "libX11.so"
#endif
#define SECATIME(sb) (sb).st_atimespec.tv_sec
#define SECCTIME(sb) (sb).st_ctimespec.tv_sec
#define SECMTIME(sb) (sb).st_mtimespec.tv_sec
#define NSECATIME(sb) (sb).st_atimespec.tv_nsec
#define NSECCTIME(sb) (sb).st_ctimespec.tv_nsec
#define NSECMTIME(sb) (sb).st_mtimespec.tv_nsec
#define ICONV_INBUF_TYPE char **
#define UNUSED __attribute__((__unused__))
#define USE_OSSP_UUID
#endif
#if (machine_type == machine_type_i3nb || machine_type == machine_type_ti3nb || machine_type == machine_type_a6nb || machine_type == machine_type_ta6nb)
#if (machine_type == machine_type_ti3nb || machine_type == machine_type_ta6nb)
#define NETBSD
#define PTHREADS
#endif
#define NOBLOCK O_NONBLOCK
#define LOAD_SHARED_OBJECT
#define USE_MMAP
#define MMAP_HEAP
#define IEEE_DOUBLE
#define LITTLE_ENDIAN_IEEE_DOUBLE
#define LDEXP
#define ARCHYPERBOLIC
#define GETPAGESIZE() getpagesize()
typedef char *memcpy_t;
struct timespec;
#define MAKE_NAN(x) { x = 0.0; x = x / x; }
#define GETWD(x) getcwd((x),PATH_MAX)
typedef int tputsputcchar;
#define LOCKF
#define DIRMARKERP(c) ((c) == '/')
#ifndef DISABLE_X11
#define LIBX11 "libX11.so"
#endif
#define SECATIME(sb) (sb).st_atimespec.tv_sec
#define SECCTIME(sb) (sb).st_ctimespec.tv_sec
#define SECMTIME(sb) (sb).st_mtimespec.tv_sec
#define NSECATIME(sb) (sb).st_atimespec.tv_nsec
#define NSECCTIME(sb) (sb).st_ctimespec.tv_nsec
#define NSECMTIME(sb) (sb).st_mtimespec.tv_nsec
#define ICONV_INBUF_TYPE const char **
#define UNUSED __attribute__((__unused__))
#define USE_NETBSD_UUID
#define USE_MBRTOWC_L
#endif
#if (machine_type == machine_type_i3nt || machine_type == machine_type_ti3nt || machine_type == machine_type_a6nt || machine_type == machine_type_ta6nt)
#if (machine_type == machine_type_ti3nt || machine_type == machine_type_ta6nt)
#define PTHREADS
#endif
#define GETPAGESIZE() S_getpagesize()
#define GETWD(x) GETCWD(x, _MAX_PATH)
#define IEEE_DOUBLE
#define LITTLE_ENDIAN_IEEE_DOUBLE
#define LOAD_SHARED_OBJECT
#define USE_VIRTUAL_ALLOC
#define NAN_INCLUDE <math.h>
#define MAKE_NAN(x) { x = sqrt(-1.0); }
#ifndef PATH_MAX
# define PATH_MAX _MAX_PATH
#endif
typedef char *memcpy_t;
struct timespec;
#ifndef __MINGW32__
# define _setjmp setjmp
# define _longjmp longjmp
# define ftruncate _chsize_s
#endif
#define LOCK_SH 1
#define LOCK_EX 2
#define LOCK_NB 4
#define LOCK_UN 8
#define FLOCK S_windows_flock
#define DIRMARKERP(c) ((c) == '/' || (c) == '\\')
#define CHDIR S_windows_chdir
#define CHMOD S_windows_chmod
#define CLOSE _close
#define DUP _dup
#define FILENO _fileno
#define FSTAT _fstat64
#define GETCWD S_windows_getcwd
#define GETPID _getpid
#define HYPOT _hypot
#define LSEEK _lseeki64
#define LSTAT S_windows_stat64
#define OFF_T __int64
#define OPEN S_windows_open
#define READ _read
#define RENAME S_windows_rename
#define RMDIR S_windows_rmdir
#define STAT S_windows_stat64
#define STATBUF _stat64
#define SYSTEM S_windows_system
#define UNLINK S_windows_unlink
#define WRITE _write
#define SECATIME(sb) (sb).st_atime
#define SECCTIME(sb) (sb).st_ctime
#define SECMTIME(sb) (sb).st_mtime
#define NSECATIME(sb) 0
#define NSECCTIME(sb) 0
#define NSECMTIME(sb) 0
#define ICONV_INBUF_TYPE char **
struct timespec;
#define UNUSED
#endif
#if (machine_type == machine_type_i3ob || machine_type == machine_type_ti3ob || machine_type == machine_type_a6ob || machine_type == machine_type_ta6ob)
#if (machine_type == machine_type_ti3ob || machine_type == machine_type_ta6ob)
#define PTHREADS
#endif
#define NOBLOCK O_NONBLOCK
#define LOAD_SHARED_OBJECT
#define USE_MMAP
#define MMAP_HEAP
#define IEEE_DOUBLE
#define LITTLE_ENDIAN_IEEE_DOUBLE
#define LDEXP
#define ARCHYPERBOLIC
#define GETPAGESIZE() getpagesize()
typedef char *memcpy_t;
struct timespec;
#define MAKE_NAN(x) { x = 0.0; x = x / x; }
#define GETWD(x) getcwd((x),PATH_MAX)
typedef int tputsputcchar;
#define LOCKF
#define DIRMARKERP(c) ((c) == '/')
#ifndef DISABLE_X11
#define LIBX11 "libX11.so"
#endif
#define SECATIME(sb) (sb).st_atimespec.tv_sec
#define SECCTIME(sb) (sb).st_ctimespec.tv_sec
#define SECMTIME(sb) (sb).st_mtimespec.tv_sec
#define NSECATIME(sb) (sb).st_atimespec.tv_nsec
#define NSECCTIME(sb) (sb).st_ctimespec.tv_nsec
#define NSECMTIME(sb) (sb).st_mtimespec.tv_nsec
#define ICONV_INBUF_TYPE char **
#define UNUSED __attribute__((__unused__))
#define USE_OSSP_UUID
#endif
#if (machine_type == machine_type_i3osx || machine_type == machine_type_ti3osx || machine_type == machine_type_a6osx || machine_type == machine_type_ta6osx)
#if (machine_type == machine_type_ti3osx || machine_type == machine_type_ta6osx)
#define PTHREADS
#endif
#if (machine_type == machine_type_a6osx || machine_type == machine_type_ta6osx)
#ifndef NO_ROSETTA_CHECK
#define CHECK_FOR_ROSETTA
extern int is_rosetta;
#endif
#endif
#define MACOSX
#define NOBLOCK O_NONBLOCK
#define LOAD_SHARED_OBJECT
#define USE_MMAP
#define MMAP_HEAP
#define IEEE_DOUBLE
#define LITTLE_ENDIAN_IEEE_DOUBLE
#define LDEXP
#define ARCHYPERBOLIC
#define GETPAGESIZE() getpagesize()
typedef char *memcpy_t;
#define MAKE_NAN(x) { x = 0.0; x = x / x; }
#define GETWD(x) getcwd((x),PATH_MAX)
typedef int tputsputcchar;
#define LOCKF
#define DIRMARKERP(c) ((c) == '/')
#ifndef DISABLE_X11
#define LIBX11 "/usr/X11R6/lib/libX11.dylib"
#endif
#define _DARWIN_USE_64_BIT_INODE
#define SECATIME(sb) (sb).st_atimespec.tv_sec
#define SECCTIME(sb) (sb).st_ctimespec.tv_sec
#define SECMTIME(sb) (sb).st_mtimespec.tv_sec
#define NSECATIME(sb) (sb).st_atimespec.tv_nsec
#define NSECCTIME(sb) (sb).st_ctimespec.tv_nsec
#define NSECMTIME(sb) (sb).st_mtimespec.tv_nsec
#define ICONV_INBUF_TYPE char **
#define UNUSED __attribute__((__unused__))
#endif
#if (machine_type == machine_type_i3qnx || machine_type == machine_type_ti3qnx)
#if (machine_type == machine_type_ti3qnx)
#define PTHREADS
#endif
#define NOBLOCK O_NONBLOCK
#define LOAD_SHARED_OBJECT
#define USE_MMAP
#define MMAP_HEAP
#define IEEE_DOUBLE
#define LITTLE_ENDIAN_IEEE_DOUBLE
#define LDEXP
#define ARCHYPERBOLIC
#define GETPAGESIZE() getpagesize()
typedef char *memcpy_t;
#define MAKE_NAN(x) { x = 0.0; x = x / x; }
#define GETWD(x) getcwd((x),PATH_MAX)
typedef int tputsputcchar;
#define LOCKF
#define DIRMARKERP(c) ((c) == '/')
#define LSEEK lseek64
#define OFF_T off64_t
#define _LARGEFILE64_SOURCE
#define SECATIME(sb) (sb).st_atime
#define SECCTIME(sb) (sb).st_ctime
#define SECMTIME(sb) (sb).st_mtime
#define NSECATIME(sb) 0
#define NSECCTIME(sb) 0
#define NSECMTIME(sb) 0
#define ICONV_INBUF_TYPE char **
#define NOFILE 256
#define UNUSED
#endif
#if (machine_type == machine_type_i3s2 || machine_type == machine_type_ti3s2 || machine_type == machine_type_a6s2 || machine_type == machine_type_ta6s2)
#if (machine_type == machine_type_ti3s2 || machine_type == machine_type_ta6s2)
#define PTHREADS
#endif
#define NOBLOCK O_NONBLOCK
#define LOAD_SHARED_OBJECT
#define USE_MMAP
#define MMAP_HEAP
#define IEEE_DOUBLE
#define LITTLE_ENDIAN_IEEE_DOUBLE
#define LDEXP
#define ARCHYPERBOLIC
#define LOG1P
#define DEFINE_MATHERR
#define GETPAGESIZE() getpagesize()
typedef char *memcpy_t;
#define MAKE_NAN(x) { x = 0.0; x = x / x; }
#define _setjmp setjmp
#define _longjmp longjmp
typedef char tputsputcchar;
#define LOCKF
#define DIRMARKERP(c) ((c) == '/')
#ifndef DISABLE_X11
#define LIBX11 "libX11.so"
#endif
#define SECATIME(sb) (sb).st_atim.tv_sec
#define SECCTIME(sb) (sb).st_ctim.tv_sec
#define SECMTIME(sb) (sb).st_mtim.tv_sec
#define NSECATIME(sb) (sb).st_atim.tv_nsec
#define NSECCTIME(sb) (sb).st_ctim.tv_nsec
#define NSECMTIME(sb) (sb).st_mtim.tv_nsec
#define ICONV_INBUF_TYPE const char **
#define UNUSED __attribute__((__unused__))
#endif
/* defaults */
#ifndef CHDIR
# define CHDIR chdir
#endif
#ifndef CHMOD
# define CHMOD chmod
#endif
#ifndef CLOSE
# define CLOSE close
#endif
#ifndef DUP
# define DUP dup
#endif
#ifndef FILENO
# define FILENO fileno
#endif
#ifndef FSTAT
# define FSTAT fstat
#endif
#ifndef GETPID
# define GETPID getpid
#endif
#ifndef HYPOT
# define HYPOT hypot
#endif
#ifndef OFF_T
# define OFF_T off_t
#endif
#ifndef LSEEK
# define LSEEK lseek
#endif
#ifndef LSTAT
# define LSTAT lstat
#endif
#ifndef OPEN
# define OPEN open
#endif
#ifndef READ
# define READ read
#endif
#ifndef RENAME
# define RENAME rename
#endif
#ifndef RMDIR
# define RMDIR rmdir
#endif
#ifndef STAT
# define STAT stat
#endif
#ifndef STATBUF
# define STATBUF stat
#endif
#ifndef SYSTEM
# define SYSTEM system
#endif
#ifndef UNLINK
# define UNLINK unlink
#endif
#ifndef WRITE
# define WRITE write
#endif

28
ta6ob/examples/Makefile Normal file
View file

@ -0,0 +1,28 @@
# Unix make file to compile the examples.
# Compilation is not necessary since the examples may be loaded from
# source, but this gives an example of how to use make for Scheme.
# * To compile files not already compiled, type "make". Only those
# files in the object list below and not yet compiled will be compiled.
# * To compile all files, type "make all". Only those files in the object
# list below will be compiled.
# * To compile one file, say "fumble.ss", type "make fumble.so". The
# file need not be in the object list below.
# * To remove the object files, type "make clean".
# * To print the examples, type "make print".
src = def.ss edit.ss fact.ss fatfib.ss fft.ss fib.ss freq.ss interpret.ss\
m4.ss macro.ss matrix.ss object.ss power.ss queue.ss rabbit.ss rsa.ss\
scons.ss setof.ss socket.ss unify.ss compat.ss ez-grammar-test.ss
obj = ${src:%.ss=%.so}
Scheme = ../bin/scheme -q
.SUFFIXES:
.SUFFIXES: .ss .so
.ss.so: ; echo '(time (compile-file "$*"))' | ${Scheme}
needed: ${obj}
all: ; echo "(time (for-each compile-file (map symbol->string '(${src}))))" | ${Scheme}
clean: ; rm -f $(obj) expr.md

291
ta6ob/examples/compat.ss Normal file
View file

@ -0,0 +1,291 @@
;;; compat.ss
;;; 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.
;;; miscellaneous definitions to make this version compatible
;;; (where possible) with previous versions...and to a small extent with
;;; other versions of scheme and other dialects of lisp as well
;;; use only those items that you need to avoid introducing accidental
;;; dependencies on other items.
(define-syntax define!
(syntax-rules ()
((_ x v) (begin (set! x v) 'x))))
(define-syntax defrec!
(syntax-rules ()
((_ x v) (define! x (rec x v)))))
(define-syntax begin0
(syntax-rules ()
((_ x y ...) (let ((t x)) y ... t))))
(define-syntax recur
(syntax-rules ()
((_ f ((i v) ...) e1 e2 ...)
(let f ((i v) ...) e1 e2 ...))))
(define-syntax trace-recur
(syntax-rules ()
((_ f ((x v) ...) e1 e2 ...)
(trace-let f ((x v) ...) e1 e2 ...))))
(define swap-box!
(lambda (b v)
(if (box? b)
(let ((x (unbox b))) (set-box! b v) x)
(error 'swap-box! "~s is not a box" b))))
(define cull
(lambda (pred? ls)
(unless (procedure? pred?)
(error 'cull "~s is not a procedure" pred?))
(let f ([l ls])
(cond
[(pair? l)
(if (pred? (car l))
(cons (car l) (f (cdr l)))
(f (cdr l)))]
[(null? l) '()]
[else (error 'cull "~s is not a proper list" ls)]))))
(define cull! cull)
(define mem
(lambda (pred? ls)
(unless (procedure? pred?)
(error 'mem "~s is not a procedure" pred?))
(let f ([l ls])
(cond
[(pair? l) (if (pred? (car l)) l (f (cdr l)))]
[(null? l) #f]
[else (error 'mem "~s is not a proper list" ls)]))))
(define rem
(lambda (pred? ls)
(unless (procedure? pred?)
(error 'rem "~s is not a procedure" pred?))
(let f ([l ls])
(cond
[(pair? l)
(if (pred? (car l))
(f (cdr l))
(cons (car l) (f (cdr l))))]
[(null? l) '()]
[else (error 'rem "~s is not a proper list" ls)]))))
(define rem!
(lambda (pred? ls)
(unless (procedure? pred?)
(error 'rem! "~s is not a procedure" pred?))
(let f ([l ls])
(cond
[(pair? l)
(if (pred? (car l))
(f (cdr l))
(begin
(set-cdr! l (f (cdr l)))
l))]
[(null? l) '()]
[else (error 'rem! "~s is not a proper list" ls)]))))
(define ass
(lambda (pred? alist)
(unless (procedure? pred?)
(error 'ass "~s is not a procedure" pred?))
(let loop ([l alist])
(cond
[(and (pair? l) (pair? (car l)))
(if (pred? (caar l))
(car l)
(loop (cdr l)))]
[(null? l) #f]
[else (error 'ass "improperly formed alist ~s" alist)]))))
(define prompt-read
(lambda (fmt . args)
(apply printf fmt args)
(read)))
(define tree-copy
(rec tree-copy
(lambda (x)
(if (pair? x)
(cons (tree-copy (car x)) (tree-copy (cdr x)))
x))))
(define ferror error)
(define *most-negative-short-integer* (most-negative-fixnum))
(define *most-positive-short-integer* (most-positive-fixnum))
(define *most-negative-fixnum* (most-negative-fixnum))
(define *most-positive-fixnum* (most-positive-fixnum))
(define *eof* (read-char (open-input-string "")))
(define short-integer? fixnum?)
(define big-integer? bignum?)
(define ratio? ratnum?)
(define float? flonum?)
(define bound? top-level-bound?)
(define global-value top-level-value)
(define set-global-value! set-top-level-value!)
(define define-global-value define-top-level-value)
(define symbol-value top-level-value)
(define set-symbol-value! set-top-level-value!)
(define put putprop)
(define get getprop)
(define copy-list list-copy)
(define copy-tree tree-copy)
(define copy-string string-copy)
(define copy-vector vector-copy)
(define intern string->symbol)
(define symbol-name symbol->string)
(define string->uninterned-symbol gensym)
(define make-temp-symbol string->uninterned-symbol)
(define uninterned-symbol? gensym?)
(define temp-symbol? uninterned-symbol?)
(define compile-eval compile)
(define closure? procedure?)
(define =? =)
(define <? <)
(define >? >)
(define <=? <=)
(define >=? >=)
(define float exact->inexact)
(define rational inexact->exact)
(define char-equal? char=?)
(define char-less? char<?)
(define string-equal? string=?)
(define string-less? string<?)
; following defn conflicts with new r6rs mod
#;(define mod modulo)
(define flush-output flush-output-port)
(define clear-output clear-output-port)
(define clear-input clear-input-port)
(define mapcar map)
(define mapc for-each)
(define true #t)
(define false #f)
(define t #t)
(define nil '())
(define macro-expand expand)
;;; old macro and structure definition
;;; thanks to Michael Lenaghan (MichaelL@frogware.com) for suggesting
;;; various improvements.
(define-syntax define-macro!
(lambda (x)
(syntax-case x ()
[(k (name arg1 ... . args)
form1
form2
...)
#'(k name (arg1 ... . args)
form1
form2
...)]
[(k (name arg1 arg2 ...)
form1
form2
...)
#'(k name (arg1 arg2 ...)
form1
form2
...)]
[(k name args . forms)
(identifier? #'name)
(letrec ((add-car
(lambda (access)
(case (car access)
((cdr) `(cadr ,@(cdr access)))
((cadr) `(caadr ,@(cdr access)))
((cddr) `(caddr ,@(cdr access)))
((cdddr) `(cadddr ,@(cdr access)))
(else `(car ,access)))))
(add-cdr
(lambda (access)
(case (car access)
((cdr) `(cddr ,@(cdr access)))
((cadr) `(cdadr ,@(cdr access)))
((cddr) `(cdddr ,@(cdr access)))
((cdddr) `(cddddr ,@(cdr access)))
(else `(cdr ,access)))))
(parse
(lambda (l access)
(cond
((null? l) '())
((symbol? l) `((,l ,access)))
((pair? l)
(append!
(parse (car l) (add-car access))
(parse (cdr l) (add-cdr access))))
(else
(syntax-error #'args
(format "invalid ~s parameter syntax" (datum k))))))))
(with-syntax ((proc (datum->syntax-object #'k
(let ((g (gensym)))
`(lambda (,g)
(let ,(parse (datum args) `(cdr ,g))
,@(datum forms)))))))
#'(define-syntax name
(lambda (x)
(syntax-case x ()
((k1 . r)
(datum->syntax-object #'k1
(proc (syntax-object->datum x)))))))))])))
(alias define-macro define-macro!)
(alias defmacro define-macro!)
(define-macro! define-struct! (name . slots)
`(begin
(define ,name
(lambda ,slots
(vector ',name ,@slots)))
(define ,(string->symbol (format "~a?" name))
(lambda (x)
(and (vector? x)
(= (vector-length x) (1+ ,(length slots)))
(eq? ',name (vector-ref x 0)))))
,@(\#make-accessors name slots)
',name))
(define \#make-accessors
(lambda (name slots)
(recur f ((n 1) (slots slots))
(if (not (null? slots))
(let*
((afn (string->symbol (format "~a-~a" name (car slots))))
(sfn (string->symbol (format "~a!" afn))))
`((define-macro! ,afn (x) `(vector-ref ,x ,,n))
(define-macro! ,sfn (x v) `(vector-set! ,x ,,n ,v))
,@(f (1+ n) (cdr slots))))
'()))))

86
ta6ob/examples/crepl.c Normal file
View file

@ -0,0 +1,86 @@
/* crepl.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.
*/
/*
This is a variant of main.c that implements a Scheme repl in C.
It's not at all useful, but it highlights how to invoke Scheme
without going through Sscheme_start.
Test in a workarea's examples subdirectory with:
( cd ../c ; ln -sf ../examples/crepl.c . )
( cd ../c ; make mainsrc=crepl.c )
sh -c 'SCHEMEHEAPDIRS=../boot/%m ../bin/scheme'
*/
#include "scheme.h"
#include <stdio.h>
#include <stdlib.h>
#define CALL0(who) Scall0(Stop_level_value(Sstring_to_symbol(who)))
#define CALL1(who, arg) Scall1(Stop_level_value(Sstring_to_symbol(who)), arg)
static void custom_init(void) {}
int main(int argc, char *argv[]) {
int n, new_argc = 1, ignoreflags = 0;
ptr p;
Sscheme_init(NULL);
/* process command-line arguments, registering boot and heap files */
for (n = 1; n < argc; n += 1) {
if (!ignoreflags && *argv[n] == '-') {
switch (*(argv[n]+1)) {
case '-': /* pass through remaining options */
if (*(argv[n]+2) != 0) break;
ignoreflags = 1;
continue;
case 'b': /* boot option, expects boot file pathname */
if (*(argv[n]+2) != 0) break;
if (++n == argc) {
(void) fprintf(stderr,"\n-b option requires argument\n");
exit(1);
}
Sregister_boot_file(argv[n]);
continue;
default:
break;
}
}
argv[new_argc++] = argv[n];
}
/* must call Sscheme_heap after registering boot and heap files
* Sscheme_heap() completes the initialization of the Scheme system
* and loads the boot or heap files. Before loading boot files,
* it calls custom_init(). */
Sbuild_heap(argv[0], custom_init);
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");
/* must call Scheme_deinit after saving the heap and before exiting */
Sscheme_deinit();
exit(0);
}

103
ta6ob/examples/csocket.c Normal file
View file

@ -0,0 +1,103 @@
/*/ csocket.c
R. Kent Dybvig May 1998
Updated by Jamie Taylor, Sept 2016
Public Domain
/*/
#include <sys/types.h>
#include <sys/socket.h>
#include <sys/un.h>
#include <string.h>
#include <errno.h>
#include <signal.h>
#include <sys/ioctl.h>
#include <stdio.h>
#include <unistd.h>
/* c_write attempts to write the entire buffer, pushing through
interrupts, socket delays, and partial-buffer writes */
int c_write(int fd, char *buf, ssize_t start, ssize_t n) {
ssize_t i, m;
buf += start;
m = n;
while (m > 0) {
if ((i = write(fd, buf, m)) < 0) {
if (errno != EAGAIN && errno != EINTR)
return i;
} else {
m -= i;
buf += i;
}
}
return n;
}
/* c_read pushes through interrupts and socket delays */
int c_read(int fd, char *buf, size_t start, size_t n) {
int i;
buf += start;
for (;;) {
i = read(fd, buf, n);
if (i >= 0) return i;
if (errno != EAGAIN && errno != EINTR) return -1;
}
}
/* bytes_ready(fd) returns true if there are bytes available
to be read from the socket identified by fd */
int bytes_ready(int fd) {
int n;
(void) ioctl(fd, FIONREAD, &n);
return n;
}
/* socket support */
/* do_socket() creates a new AF_UNIX socket */
int do_socket(void) {
return socket(AF_UNIX, SOCK_STREAM, 0);
}
/* do_bind(s, name) binds name to the socket s */
int do_bind(int s, char *name) {
struct sockaddr_un sun;
int length;
sun.sun_family = AF_UNIX;
(void) strcpy(sun.sun_path, name);
length = sizeof(sun.sun_family) + sizeof(sun.sun_path);
return bind(s, (struct sockaddr*)(&sun), length);
}
/* do_accept accepts a connection on socket s */
int do_accept(int s) {
struct sockaddr_un sun;
socklen_t length;
length = sizeof(sun.sun_family) + sizeof(sun.sun_path);
return accept(s, (struct sockaddr*)(&sun), &length);
}
/* do_connect initiates a socket connection */
int do_connect(int s, char *name) {
struct sockaddr_un sun;
int length;
sun.sun_family = AF_UNIX;
(void) strcpy(sun.sun_path, name);
length = sizeof(sun.sun_family) + sizeof(sun.sun_path);
return connect(s, (struct sockaddr*)(&sun), length);
}
/* get_error returns the operating system's error status */
char* get_error(void) {
extern int errno;
return strerror(errno);
}

125
ta6ob/examples/def.ss Normal file
View file

@ -0,0 +1,125 @@
;;; def.ss
;;; Copyright (C) 1987 R. Kent Dybvig
;;; Permission is hereby granted, free of charge, to any person obtaining a
;;; copy of this software and associated documentation files (the "Software"),
;;; to deal in the Software without restriction, including without limitation
;;; the rights to use, copy, modify, merge, publish, distribute, sublicense,
;;; and/or sell copies of the Software, and to permit persons to whom the
;;; Software is furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be included in
;;; all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
;;; THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.
;;; Prototype code for definition facility that remembers definitions and
;;; allows you to pretty-print or edit them (using the structure editor
;;; defined in the file "edit.ss").
;;; def can be in place of define at top level (i.e., not within a lambda,
;;; let, let*, or letrec body). It saves the source for the definition
;;; as well as performing the defintion. Type (ls-def) for a list of
;;; variables defined this session, and (pp-def variable) to return the
;;; definition of a particular variable.
;;; Possible exercises/enhancements:
;;;
;;; 1) Write a "dskout" function that pretty-prints the definitions of
;;; all or selected variables defined this session to a file.
;;;
;;; 2) In place of "def", write a modified "load" that remembers where
;;; (that is, in which file) it saw the definition for each variable
;;; defined in a particular session. This would be used instead of
;;; the "def" form. "ls-def" would be similar to what it is now.
;;; "pp-def" could be similar to what it is now, or it could involve
;;; rereading the corresponding file. "ed-def" could invoke the
;;; structure editor and (as an option) print the modified definition
;;; back to the corresponding file, or "ed-def" could invoke a host
;;; editor (such as Unix "vi" or VMS "edit") on the corresponding
;;; source file, with an option to reload. If this tool is smart
;;; enough, it could get around the limitation that definitions use
;;; define at top-level, i.e., (let ([x #f]) (set! foo (lambda () x)))
;;; could be recognized as a definition for foo.
(define-syntax def
;; only makes sense for "top level" definitions
(syntax-rules ()
[(_ (var . formals) . body)
(begin (define (var . formals) . body)
(insert-def! 'var '(def (var . formals) . body) var)
'var)]
[(_ var exp)
(begin (define var exp)
(insert-def! 'var '(def var exp) var)
'var)]))
(define-syntax pp-def
(syntax-rules (quote)
; allow var to be unquoted or quoted
[(_ var) (pp-def-help 'var var)]
[(_ 'var) (pp-def-help 'var var)]))
(define-syntax ed-def
(syntax-rules (quote)
; allow var to be unquoted or quoted
[(_ var) (ed-def-help 'var var)]
[(_ 'var) (ed-def-help 'var var)]))
(define insert-def! #f) ; assigned within the let below
(define ls-def #f) ; assigned within the let below
(define pp-def-help #f) ; assigned within the let below
(define ed-def-help #f) ; assigned within the let below
(let ([defs '()])
(define tree-copy
(rec tree-copy
(lambda (x)
(if (pair? x)
(cons (tree-copy (car x)) (tree-copy (cdr x)))
x))))
(set! insert-def!
(lambda (var defn val)
(unless (symbol? var)
(error 'insert-def! "~s is not a symbol" var))
(let ([a (assq var defs)])
(if a
(set-cdr! a (cons defn val))
(set! defs (cons (cons var (cons defn val)) defs))))))
(set! ls-def
(lambda ()
(map car defs)))
(set! pp-def-help
(lambda (var val)
(unless (symbol? var)
(error 'pp-def "~s is not a symbol" var))
(let ([a (assq var defs)])
(unless a
(error 'pp-def
"~s has not been defined during this session"
var))
(unless (eq? (cddr a) val)
(printf "Warning: ~s has been reassigned since definition"
var))
(cadr a))))
(set! ed-def-help
(lambda (var val)
(unless (symbol? var)
(error 'ed-def "~s is not a symbol" var))
(let ([a (assq var defs)])
(unless a
(error 'ed-def
"~s has not been defined during this session"
var))
(unless (eq? (cddr a) val)
(printf "Warning: ~s reassigned since last definition"
var))
; edit is destructive; the copy allows the defined name to
; be changed without affecting the old name's definition
(eval (edit (tree-copy (cadr a))))))))

464
ta6ob/examples/edit.ss Normal file
View file

@ -0,0 +1,464 @@
;;; edit.ss
;;; Copyright (C) 1987 R. Kent Dybvig
;;; Permission is hereby granted, free of charge, to any person obtaining a
;;; copy of this software and associated documentation files (the "Software"),
;;; to deal in the Software without restriction, including without limitation
;;; the rights to use, copy, modify, merge, publish, distribute, sublicense,
;;; and/or sell copies of the Software, and to permit persons to whom the
;;; Software is furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be included in
;;; all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
;;; THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.
;;; This file contains an implementation of a simple interactive structure
;;; editor for Scheme. The editor is invoked with an expression as it's
;;; single argument. It prompts for, reads, and processes editor commands.
;;; The editor commands recognized are those documented in the Texas
;;; Instruments' PC Scheme manual. They are summarized below.
;;; Command syntax Action
;;;
;;; q or <eof> Quit the editor, returning edited expression.
;;;
;;; p Write the current expression.
;;;
;;; ? Write to level 2, length 10.
;;;
;;; pp Pretty print the current expression.
;;;
;;; ?? Pretty print to level 2, length 10.
;;;
;;; <pos> Move to subexpression of current expression
;;; <pos> = 0 is the current expression, <pos> > 0
;;; is the numbered subexpression (1 for first, 2
;;; for second, ...), <pos> < 0 is the numbered
;;; subexpression from the right (-1 for last, -2
;;; for second to last, ...), and <pos> = * is the
;;; "last cdr" of the current expression. If <pos>
;;; is not 0, the current expression must be a list.
;;;
;;; b Move back to parent expression.
;;;
;;; t Move to top-level expression.
;;;
;;; pr Move to expression on the left (previous).
;;;
;;; n Move to expression on the right (next).
;;;
;;; (f <obj>) Find <obj> within or to the right of the current
;;; expression using equal?.
;;;
;;; f or (f) Find <obj> of last (f <obj>) command.
;;;
;;; (d <pos>) Delete the expression at position <pos>.
;;;
;;; (r <pos> <obj>) Replace the expression at position <pos> with
;;; <obj>.
;;;
;;; (s <obj1> <obj2>) Replace all occurrences of <obj1> by <obj2>
;;; within the current expression.
;;;
;;; (dp <pos>) Remove parens from around expression at position
;;; <pos>.
;;;
;;; (ap <pos1> <pos2>) Insert parens around expressions from position
;;; <pos1> through <pos2> (inclusive). If <pos1> is
;;; 0 or *, <pos2> is ignored and may be omitted.
;;;
;;; (ib <pos> <obj>) Insert <obj> before expression at position <pos>.
;;;
;;; (ia <pos> <obj>) Insert <obj> after expression at position <pos>.
;;;
;;; (sb <pos> <obj>) Splice <obj> before expression at position <pos>.
;;;
;;; (sa <pos> <obj>) Splice <obj> after expression at position <pos>.
;;; Possible exercises/enhancements:
;;;
;;; 1) Implement an infinite undo ("u") command in the editor. This
;;; can be done by creating an "inverse" function for each operation
;;; that causes a side-effect, i.e, a closure that "remembers" the
;;; list cells involved and knows how to put them back the way they
;;; were. An undo (u) variable could then be added to the editor's
;;; main loop; it would be bound to a list containing the set of
;;; registers at the point of the last side-effect (similarly to the
;;; "back" (b) variable) and the undo function for the side-effect.
;;;
;;; 2) Implement an infinite redo ("r") command in the editor. This
;;; can be done by remembering the undo functions and registers for
;;; the undo's since the last non-undo command.
;;;
;;; 3) Handle circular structures better in the editor. Specifically,
;;; modify the find ("f") command so that it always terminates, and
;;; devise a method for printing circular structures with the "p"
;;; and "pp" commands. Cure the bug mentioned in the overview of
;;; the code given later in the file.
;;;
;;; 4) Add a help ("h") command to the editor. This could be as simple
;;; as listing the available commands.
;;;
;;; 5) Make the editor "extensible" via user-defined macros or editor
;;; commands written in Scheme.
;;;
;;; 6) Modify the editor to provide more descriptive error messages that
;;; diagnose the problem and attempt to give some help. For example,
;;; if the editor receives "(r 1)" it might respond with:
;;; "Two few arguments:
;;; Type (r pos exp) to replace the expression at position pos
;;; with the expression exp."
;;; This should be implemented in conjunction with the help command.
;;; Should it be possible to disable such verbose error messages?
;;; Implementation:
;;;
;;; The main editor loop and many of the help functions operate on a
;;; set of "registers". These registers are described below:
;;;
;;; s The current find object. s is initially #f, and is bound to a
;;; pair containing the find object when the first (f <obj>) command
;;; is seen. The identical f and (f) commands use the saved object.
;;;
;;; p The parent of the current expression. This is initially a list
;;; of one element, the argument to edit. It is updated by various
;;; movement commands.
;;;
;;; i The index of the current expression in the parent (p). This is
;;; initially 0. It is updated by various movement commands.
;;;
;;; b The "back" chain; actually a list containing the registers p, i
;;; and b for the parent of the current expression. It is initially
;;; (). It is updated by various movement commands.
;;;
;;; Bugs:
;;;
;;; When editing a circular structure, it is possible for the editor to
;;; get lost. That is, when the parent node of the current expression
;;; is changed by a command operating on a subexpression of the current
;;; expression, the index for the current expression may become incorrect.
;;; This can result in abnormal termination of the editor. It would be
;;; fairly simple to check for this (in list-ref) and reset the editor,
;;; and it may be possible to use a different set of registers to avoid
;;; the problem altogether.
(define edit #f) ; assigned within the let expression below
(let ()
(define cmdeq?
;; used to check command syntax
(lambda (cmd pat)
(and (pair? cmd)
(eq? (car cmd) (car pat))
(let okargs? ([cmd (cdr cmd)] [pat (cdr pat)])
(if (null? pat)
(null? cmd)
(and (not (null? cmd))
(okargs? (cdr cmd) (cdr pat))))))))
(define find
;; find expression within or to right of current expression
(lambda (s0 p0 i0 b0)
(define check
(lambda (p i b)
(if (equal? (list-ref p i) (car s0))
(wrlev s0 p i b)
(continue p i b))))
(define continue
(lambda (p i b)
(let ([e (list-ref p i)])
(if (atom? e)
(let next ([p p] [i i] [b b])
(let ([n (maxref p)])
(if (or (not n) (< i n))
(check p (+ i 1) b)
(if (null? b)
(search-failed s0 p0 i0 b0)
(apply next b)))))
(check e 0 (list p i b))))))
(continue p0 i0 b0)))
(define maxref
;; use "hare and tortoise" algorithm to check for circular lists.
;; return maximum reference index (zero-based) for a list x. return
;; -1 for atoms and #f for circular lists.
(lambda (x)
(let f ([hare x] [tortoise x] [n -1])
(cond
[(atom? hare) n]
[(atom? (cdr hare)) (+ n 1)]
[(eq? (cdr hare) tortoise) #f]
[else (f (cddr hare) (cdr tortoise) (+ n 2))]))))
(define move
;; move to subexpression specified by x and pass current state to k.
(lambda (x s p i b k)
(cond
[(eqv? x 0) (k s p i b)]
[(eq? x '*)
(let ([m (maxref (list-ref p i))])
(if m
(k s (list-ref p i) '* (list p i b))
(invalid-movement s p i b)))]
[(> x 0)
(let ([m (maxref (list-ref p i))] [x (- x 1)])
(if (or (not m) (>= m x))
(k s (list-ref p i) x (list p i b))
(invalid-movement s p i b)))]
[else
(let ([m (maxref (list-ref p i))] [x (- -1 x)])
(if (and m (>= m x))
(let ([x (- m x)])
(k s (list-ref p i) x (list p i b)))
(invalid-movement s p i b)))])))
(define proper-list?
;; return #t if x is a proper list.
(lambda (x)
(and (maxref x)
(or (null? x) (null? (cdr (last-pair x)))))))
(define list-ref
;; reference list ls element i. i may be *, in which case return
;; the last pair of ls.
(lambda (ls i)
(if (eq? i '*)
(cdr (last-pair ls))
(car (list-tail ls i)))))
(define list-set!
;; change element i of ls to x.
(lambda (ls i x)
(if (eq? i '*)
(set-cdr! (last-pair ls) x)
(set-car! (list-tail ls i) x))))
(define list-cut!
;; remove element i from ls.
(lambda (ls i)
(let ([a (cons '() ls)])
(set-cdr! (list-tail a i) (list-tail a (+ i 2)))
(cdr a))))
(define list-splice!
;; insert ls2 into ls1 in place of element i.
(lambda (ls1 i ls2)
(let ([a (list-tail ls1 i)])
(unless (null? (cdr a))
(set-cdr! (last-pair ls2) (cdr a)))
(set-car! a (car ls2))
(set-cdr! a (cdr ls2)))
ls1))
(define list-ap*!
;; place parens from element i through last pair of ls.
(lambda (ls i)
(let ([a (list-tail ls i)])
(let ([c (cons (car a) (cdr a))])
(set-car! a c)
(set-cdr! a '())))
ls))
(define list-ap!
;; place parens from element i0 through element i1.
(lambda (ls i0 i1)
(let ([a (list-tail ls i0)] [b (list-tail ls i1)])
(let ([c (cons (car a) (cdr a))])
(set-car! a c)
(if (eq? a b)
(set-cdr! c '())
(begin (set-cdr! a (cdr b))
(set-cdr! b '())))))
ls))
(define wrlev
;; write current expression to level 2, length 10 and continue.
(lambda (s p i b)
(parameterize ([print-level 2] [print-length 10])
(printf "~s~%" (list-ref p i)))
(edit-loop s p i b)))
(define wr
;; write current expression and continue.
(lambda (s p i b)
(printf "~s~%" (list-ref p i))
(edit-loop s p i b)))
(define pplev
;; pretty print current expression to level 2, length 10 and continue.
(lambda (s p i b)
(parameterize ([print-level 2] [print-length 10])
(pretty-print (list-ref p i)))
(edit-loop s p i b)))
(define pp
;; pretty print current expression and continue.
(lambda (s p i b)
(pretty-print (list-ref p i))
(edit-loop s p i b)))
(define not-a-proper-list
;; complain and continue.
(lambda (s p i b)
(printf "structure is not a proper list~%")
(edit-loop s p i b)))
(define cannot-dp-zero
;; complain and continue.
(lambda (s p i b)
(printf "cannot remove parens from current expression~%")
(edit-loop s p i b)))
(define pos2-before-pos1
;; complain and continue.
(lambda (s p i b)
(printf "second position before first~%")
(edit-loop s p i b)))
(define invalid-movement
;; complain and continue.
(lambda (s p i b)
(printf "no such position~%")
(edit-loop s p i b)))
(define unrecognized-command-syntax
;; complain and continue.
(lambda (s p i b)
(printf "unrecognized command syntax~%")
(edit-loop s p i b)))
(define search-failed
;; complain and continue.
(lambda (s p i b)
(printf "search failed~%")
(edit-loop s p i b)))
(define no-previous-find
;; complain and continue.
(lambda (s p i b)
(printf "no previous find command~%")
(edit-loop s p i b)))
(define edit-loop
;; read command and process.
(lambda (s p i b)
(let ([x (begin (printf "edit> ") (read))])
(cond
[(eof-object? x) (newline)] ; need newline after eof
[(eq? x 'q)] ; do not need newline after q
[(eq? x 'p) (wr s p i b)]
[(eq? x '?) (wrlev s p i b)]
[(eq? x 'pp) (pp s p i b)]
[(eq? x '??) (pplev s p i b)]
[(or (integer? x) (eqv? x '*)) (move x s p i b wrlev)]
[(eq? x 't)
(let f ([p p] [i i] [b b])
(if (null? b)
(wrlev s p i b)
(apply f b)))]
[(eq? x 'b)
(if (pair? b)
(apply wrlev s b)
(invalid-movement s p i b))]
[(eq? x 'n)
(let ([n (maxref p)])
(if (and (not (eq? i '*)) (or (not n) (< i n)))
(wrlev s p (+ i 1) b)
(invalid-movement s p i b)))]
[(eq? x 'pr)
(if (and (not (eq? i '*)) (> i 0))
(wrlev s p (- i 1) b)
(invalid-movement s p i b))]
[(or (eq? x 'f) (cmdeq? x '(f)))
(if s
(find s p i b)
(no-previous-find s p i b))]
[(cmdeq? x '(f x))
(find (cons (cadr x) '()) p i b)]
[(and (cmdeq? x '(r x x))
(or (integer? (cadr x)) (eq? (cadr x) '*)))
(move (cadr x) s p i b
(lambda (s0 p0 i0 b0)
(list-set! p0 i0 (caddr x))))
(wrlev s p i b)]
[(cmdeq? x '(s x x))
(list-set! p i (subst! (caddr x) (cadr x) (list-ref p i)))
(wrlev s p i b)]
[(and (cmdeq? x '(d x)) (eqv? (cadr x) 0))
(list-set! p i '())
(wrlev s p i b)]
[(and (cmdeq? x '(d x)) (eq? (cadr x) '*))
(move (cadr x) s p i b
(lambda (s0 p0 i0 b0)
(set-cdr! (last-pair p0) '())
(wrlev s p i b)))]
[(and (cmdeq? x '(d x)) (integer? (cadr x)))
(move (cadr x) s p i b
(lambda (s0 p0 i0 b0)
(list-set! p i (list-cut! p0 i0))
(wrlev s p i b)))]
[(and (cmdeq? x '(dp x)) (eqv? (cadr x) 0))
(let ([e (list-ref p i)])
(if (and (pair? e) (null? (cdr e)))
(begin (list-set! p i (car e))
(wrlev s p i b))
(cannot-dp-zero s p i b)))]
[(and (cmdeq? x '(dp x))
(and (integer? (cadr x)) (not (= (cadr x) 0))))
(move (cadr x) s p i b
(lambda (s0 p0 i0 b0)
(let ([e0 (list-ref p0 i0)])
(if (or (proper-list? e0)
(and (pair? e0) (eqv? i0 (maxref p0))))
(begin (if (null? e0)
(list-set! p i (list-cut! p0 i0))
(list-splice! p0 i0 e0))
(wrlev s p i b))
(not-a-proper-list s p i b)))))]
[(and (or (cmdeq? x '(ap x)) (cmdeq? x '(ap x x)))
(memv (cadr x) '(0 *)))
(move (cadr x) s p i b
(lambda (s0 p0 i0 b0)
(list-set! p0 i0 (list (list-ref p0 i0)))
(wrlev s p i b)))]
[(and (cmdeq? x '(ap x x))
(and (integer? (cadr x)) (not (= (cadr x) 0)))
(eq? (caddr x) '*))
(move (cadr x) s p i b
(lambda (s0 p0 i0 b0)
(list-ap*! p0 i0)
(wrlev s p i b)))]
[(and (cmdeq? x '(ap x x))
(and (integer? (cadr x)) (not (= (cadr x) 0)))
(and (integer? (caddr x)) (not (= (caddr x) 0))))
(move (cadr x) s p i b
(lambda (s0 p0 i0 b0)
(move (caddr x) s p i b
(lambda (s1 p1 i1 b1)
(if (>= i1 i0)
(begin (list-ap! p0 i0 i1)
(wrlev s p i b))
(pos2-before-pos1 s p i b))))))]
[(and (cmdeq? x '(ib x x))
(and (integer? (cadr x)) (not (= (cadr x) 0))))
(move (cadr x) s p i b
(lambda (s0 p0 i0 b0)
(list-splice! p0 i0 (list (caddr x) (list-ref p0 i0)))
(wrlev s p i b)))]
[(and (cmdeq? x '(ia x x))
(and (integer? (cadr x)) (not (= (cadr x) 0))))
(move (cadr x) s p i b
(lambda (s0 p0 i0 b0)
(list-splice! p0 i0 (list (list-ref p0 i0) (caddr x)))
(wrlev s p i b)))]
[(and (cmdeq? x '(sb x x))
(and (integer? (cadr x)) (not (= (cadr x) 0))))
(move (cadr x) s p i b
(lambda (s0 p0 i0 b0)
(list-splice! p0 i0
(append (caddr x) (list (list-ref p0 i0))))
(wrlev s p i b)))]
[(and (cmdeq? x '(sa x x))
(and (integer? (cadr x)) (not (= (cadr x) 0))))
(move (cadr x) s p i b
(lambda (s0 p0 i0 b0)
(list-splice! p0 i0 (cons (list-ref p0 i0) (caddr x)))
(wrlev s p i b)))]
[else
(unrecognized-command-syntax s p i b)]))))
(set! edit
;; set up keyboard interrupt handler and go.
(lambda (e)
(let ([p (cons e '())])
(let ([k (call/cc (lambda (k) k))]) ; return here on interrupt
(parameterize ([keyboard-interrupt-handler
(lambda ()
(printf "reset~%")
(k k))])
(wrlev #f p 0 '())
(car p)))))))

570
ta6ob/examples/ez-grammar-test.ss Normal file
View file

@ -0,0 +1,570 @@
;;; Copyright 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 contains a sample parser defined via the ez-grammar system
;;; and a simple test of the parser.
;;; This file is organized as follows:
;;;
;;; - (streams) library providing the required exports for ez-grammar and
;;; the parser.
;;;
;;; - (state-case) library exporting the state-case macro, copped from
;;; cmacros.ss, for use by the lexer.
;;;
;;; - (lexer) library providing a simple lexer that reads characters
;;; from a port and produces a corresponding stream of tokens.
;;;
;;; - (parser) library providing the sample parser.
;;;
;;; - ez-grammar-test procedure that tests the sample parser.
;;;
;;; Instructions for running the test are at the end of this file.
(library (streams)
(export stream-cons stream-car stream-cdr stream-nil stream-null?
stream-map stream stream-append2 stream-append-all stream-last-forced)
(import (chezscheme))
(define stream-cons
(lambda (x thunk)
(cons x thunk)))
(define stream-car
(lambda (x)
(car x)))
(define stream-cdr
(lambda (x)
(when (procedure? (cdr x)) (set-cdr! x ((cdr x))))
(cdr x)))
(define stream-nil '())
(define stream-null?
(lambda (x)
(null? x)))
(define stream-map
(lambda (f x)
(if (stream-null? x)
'()
(stream-cons (f (stream-car x))
(lambda ()
(stream-map f (stream-cdr x)))))))
(define stream
(lambda xs
xs))
(define stream-append2
(lambda (xs thunk)
(if (null? xs)
(thunk)
(stream-cons (stream-car xs)
(lambda ()
(stream-append2 (stream-cdr xs) thunk))))))
(define stream-append-all
(lambda (stream$) ;; stream of streams
(if (stream-null? stream$)
stream$
(stream-append2 (stream-car stream$)
(lambda () (stream-append-all (stream-cdr stream$)))))))
(define stream-last-forced
(lambda (x)
(and (not (null? x))
(let loop ([x x])
(let ([next (cdr x)])
(if (pair? next)
(loop next)
(car x)))))))
)
(library (state-case)
(export state-case eof)
(import (chezscheme))
;;; from Chez Scheme Version 9.5.1 cmacros.ss
(define-syntax state-case
(lambda (x)
(define state-case-test
(lambda (cvar k)
(with-syntax ((cvar cvar))
(syntax-case k (-)
(char
(char? (datum char))
#'(char=? cvar char))
((char1 - char2)
(and (char? (datum char1)) (char? (datum char2)))
#'(char<=? char1 cvar char2))
(predicate
(identifier? #'predicate)
#'(predicate cvar))))))
(define state-case-help
(lambda (cvar clauses)
(syntax-case clauses (else)
(((else exp1 exp2 ...))
#'(begin exp1 exp2 ...))
((((k ...) exp1 exp2 ...) . more)
(with-syntax (((test ...)
(map (lambda (k) (state-case-test cvar k))
#'(k ...)))
(rest (state-case-help cvar #'more)))
#'(if (or test ...) (begin exp1 exp2 ...) rest)))
(((k exp1 exp2 ...) . more)
(with-syntax ((test (state-case-test cvar #'k))
(rest (state-case-help cvar #'more)))
#'(if test (begin exp1 exp2 ...) rest))))))
(syntax-case x (eof)
((_ cvar (eof exp1 exp2 ...) more ...)
(identifier? #'cvar)
(with-syntax ((rest (state-case-help #'cvar #'(more ...))))
#'(if (eof-object? cvar)
(begin exp1 exp2 ...)
rest))))))
(define-syntax eof
(lambda (x)
(syntax-error x "misplaced aux keyword")))
)
(library (lexer)
(export token? token-type token-value token-bfp token-efp lexer)
(import (chezscheme) (state-case) (streams))
(define-record-type token
(nongenerative)
(fields type value bfp efp))
;; test lexer
(define lexer
(lambda (fn ip)
(define $prev-pos 0)
(define $pos 0)
(define ($get-char)
(set! $pos (+ $pos 1))
(get-char ip))
(define ($unread-char c)
(set! $pos (- $pos 1))
(unread-char c ip))
(define ($ws!) (set! $prev-pos $pos))
(define ($make-token type value)
(let ([tok (make-token type value $prev-pos $pos)])
(set! $prev-pos $pos)
tok))
(define ($lex-error c)
(errorf #f "unexpected ~a at character ~s of ~a"
(if (eof-object? c)
"eof"
(format "character '~c'" c))
$pos fn))
(define-syntax lex-error
(syntax-rules ()
[(_ ?c)
(let ([c ?c])
($lex-error c)
(void))]))
(let-values ([(sp get-buf) (open-string-output-port)])
(define (return-token type value)
(stream-cons ($make-token type value) lex))
(module (identifier-initial? identifier-subsequent?)
(define identifier-initial?
(lambda (c)
(char-alphabetic? c)))
(define identifier-subsequent?
(lambda (c)
(or (char-alphabetic? c)
(char-numeric? c)))))
(define-syntax define-state-case
(syntax-rules ()
[(_ ?def-id ?char-id clause ...)
(define (?def-id)
(let ([?char-id ($get-char)])
(state-case ?char-id clause ...)))]))
(define-state-case lex c
[eof stream-nil]
[char-whitespace? ($ws!) (lex)]
[char-numeric? (lex-number c)]
[#\/ (seen-slash)]
[identifier-initial? (put-char sp c) (lex-identifier)]
[#\( (return-token 'lparen #\()]
[#\) (return-token 'rparen #\))]
[#\! (return-token 'bang #\!)]
[#\+ (seen-plus)]
[#\- (seen-minus)]
[#\= (seen-equals)]
[#\* (return-token 'binop '*)]
[#\, (return-token 'sep #\,)]
[#\; (return-token 'sep #\;)]
[else (lex-error c)])
(module (lex-identifier)
(define (id) (return-token 'id (string->symbol (get-buf))))
(define-state-case next c
[eof (id)]
[identifier-subsequent? (put-char sp c) (next)]
[else ($unread-char c) (id)])
(define (lex-identifier) (next)))
(define-state-case seen-plus c
[eof (return-token 'binop '+)]
[char-numeric? (lex-signed-number #\+ c)]
[else (return-token 'binop '+)])
(define-state-case seen-minus c
[eof (return-token 'binop '-)]
[char-numeric? (lex-signed-number #\- c)]
[else (return-token 'binop '-)])
(define-state-case seen-equals c
[eof (return-token 'binop '=)]
[#\> (return-token 'big-arrow #f)]
[else (return-token 'binop '=)])
(module (lex-number lex-signed-number)
(define (finish-number)
(let ([str (get-buf)])
(let ([n (string->number str 10)])
(unless n (errorf 'lexer "unexpected number literal ~a" str))
(return-token 'integer n))))
(define (num)
(let ([c ($get-char)])
(state-case c
[eof (finish-number)]
[char-numeric? (put-char sp c) (num)]
[else ($unread-char c) (finish-number)])))
(define (lex-signed-number s c)
(put-char sp s)
(lex-number c))
(define (lex-number c)
(state-case c
[eof (assert #f)]
[char-numeric? (put-char sp c) (num)]
[else (assert #f)])))
(define-state-case seen-slash c
[eof (return-token 'binop '/)]
[#\* (lex-block-comment)]
[#\/ (lex-comment)]
[else (return-token 'binop '/)])
(define-state-case lex-comment c
[eof (lex)]
[#\newline ($ws!) (lex)]
[else (lex-comment)])
(define (lex-block-comment)
(define-state-case maybe-end-comment c
[eof (lex-error c)]
[#\/ ($ws!) (lex)]
[else (lex-block-comment)])
(let ([c ($get-char)])
(state-case c
[eof (lex-error c)]
[#\* (maybe-end-comment)]
[else (lex-block-comment)])))
(lex))))
(record-writer (record-type-descriptor token)
(lambda (x p wr)
(put-char p #\[)
(wr (token-type x) p)
(put-char p #\,)
(put-char p #\space)
(wr (token-value x) p)
(put-char p #\])
(put-char p #\:)
(wr (token-bfp x) p)
(put-char p #\-)
(wr (token-efp x) p)))
)
(module parser ()
(export parse *sfd*)
(import (chezscheme) (streams) (lexer))
(define *sfd*)
(module (define-grammar is sat parse-consumed-all? parse-result-value grammar-trace make-src)
(define (sep->parser sep)
(cond
[(char? sep) (sat (lambda (x) (and (eq? (token-type x) 'sep) (eq? (token-value x) sep))))]
[(symbol? sep) (sat (lambda (x) (eq? (token-type x) sep)))]
[else (errorf "don't know how to parse separator: ~s" sep)]))
(meta define (constant? x) (let ([x (syntax->datum x)]) (or (string? x) (char? x))))
(define constant->parser
(lambda (const)
(define (token-sat type val)
(sat (lambda (x)
(let ([ans (and (token? x) (eqv? (token-type x) type) (eqv? (token-value x) val))])
(when (grammar-trace) (printf " ~s is [~s, ~a]? => ~s~%" x type val ans))
ans))))
(if (string? const)
(case const
[else (token-sat 'id (string->symbol const))])
(case const
[#\( (token-sat 'lparen const)]
[#\) (token-sat 'rparen const)]
[#\! (token-sat 'bang const)]
[else (errorf 'constant->parser "don't know how to construct a parser for ~a" const)]))))
(meta define (constant->markdown k)
(format "~a" k))
(define binop->parser
(lambda (binop)
(define (binop-sat type val)
(is val
(where [x <- item] (and (token? x) (eq? (token-type x) type) (eq? (token-value x) val)))))
(define (unexpected) (errorf 'binop->parser "don't know how to construct a parser for ~a" binop))
(if (string? binop)
(binop-sat 'binop
(case binop
["=" '=]
["+" '+]
["-" '-]
["*" '*]
["/" '/]
[else (unexpected)]))
(unexpected))))
(define make-src
(lambda (bfp efp)
(make-source-object *sfd* bfp efp)))
(include "ez-grammar.ss"))
(define token
(case-lambda
[(type)
(is (token-value x)
(where
[x <- (sat (lambda (x)
(let ([ans (eq? (token-type x) type)])
(when (grammar-trace) (printf " ~s is ~s? => ~s~%" x type ans))
ans)))]))]
[(type val)
(is (token-value x)
(where
[x <- (sat (lambda (x)
(let ([ans (and
(eq? (token-type x) type)
(eqv? (token-value x) val))])
(when (grammar-trace) (printf " ~s is [~s, ~s]? => ~s~%" x type val ans))
ans)))]))]))
(define identifier (token 'id))
(define integer (token 'integer))
(define-grammar expr (markdown-directory ".")
(TERMINALS
(identifier (x y) (DESCRIPTION ("An identifier is ...")))
(integer (i) (DESCRIPTION ("An integer literal is ..."))))
(expr (e)
(BINOP src ((RIGHT "=") (LEFT "+" "-") (LEFT "*" "/")) t) =>
(lambda (src op x y)
(make-annotation `(,op ,x ,y) src `(,op ,(annotation-stripped x) ,(annotation-stripped y)))))
(term (t)
[test-SEP+ :: src "sepplus" #\( (SEP+ e #\;) #\) =>
(lambda (src e+)
(make-annotation `(SEP+ ,@e+) src `(SEP+ ,@(map annotation-stripped e+))))]
[test-SEP* :: src "sepstar" #\( (SEP* e #\,) #\) =>
(lambda (src e*)
(make-annotation `(SEP* ,@e*) src `(SEP* ,@(map annotation-stripped e*))))]
[test-OPT :: src "opt" #\( (OPT e #f) #\) =>
(lambda (src maybe-e)
(if maybe-e
(make-annotation `(OPT ,maybe-e) src `(OPT ,(annotation-stripped maybe-e)))
(make-annotation `(OPT) src `(OPT))))]
[test-K+ :: src "kplus" #\( (K+ e) #\) =>
(lambda (src e+)
(make-annotation `(K+ ,@e+) src `(K+ ,@(map annotation-stripped e+))))]
[test-K* :: src "kstar" #\( (K* e) #\) =>
(lambda (src e*)
(make-annotation `(K* ,@e*) src `(K* ,@(map annotation-stripped e*))))]
[varref :: src x =>
(lambda (src id)
(make-annotation `(id ,id) src `(id ,id)))]
[intref :: src i =>
(lambda (src n)
(make-annotation `(int ,n) src `(int ,n)))]
[group :: src #\( e #\) =>
(lambda (src e)
`(group ,src ,e))]))
(define parse
(lambda (fn ip)
(let ([token-stream (lexer fn ip)])
(define (oops)
(let ([last-token (stream-last-forced token-stream)])
(if last-token
(errorf 'parse "parse error at or before character ~s of ~a" (token-bfp last-token) fn)
(errorf 'parse "no expressions found in ~a" fn))))
;;; return the first result, if any, for which the input stream was entirely consumed.
(let loop ([res* (expr token-stream)])
(if (null? res*)
(oops)
(let ([res (car res*)])
(if (parse-consumed-all? res)
(parse-result-value res)
(loop (cdr res*))))))))))
(define run
(lambda (fn)
(import parser)
(let* ([ip (open-file-input-port fn)]
[sfd (make-source-file-descriptor fn ip #t)]
[ip (transcoded-port ip (native-transcoder))])
(fluid-let ([*sfd* sfd])
(eval
`(let ()
(define-syntax define-ops
(lambda (x)
(syntax-case x ()
[(_ op ...)
#`(begin
(define-syntax op
(lambda (x)
(let ([src (annotation-source (syntax->annotation x))])
(with-syntax ([bfp (source-object-bfp src)] [efp (source-object-efp src)])
(syntax-case x ()
[(_ e (... ...)) #'`(op (bfp . efp) ,e (... ...))])))))
...)])))
(define-ops SEP+ SEP* OPT K+ K* id int group)
(define-ops = + - * /)
(define x 'x)
(define y 'y)
(define z 'z)
,(dynamic-wind
void
(lambda () (parse fn ip))
(lambda () (close-input-port ip)))))))))
(define (ez-grammar-test)
(define n 0)
(define test
(lambda (line* okay?)
(set! n (+ n 1))
(let ([fn (format "testfile~s" n)])
(with-output-to-file fn
(lambda () (for-each (lambda (line) (printf "~a\n" line)) line*))
'replace)
(let ([result (parameterize ([compile-profile #t] [compile-interpret-simple #f])
(guard (c [else c]) (run fn)))])
(guard (c [else #f]) (profile-dump-html))
(delete-file fn)
(delete-file "profile.html")
(delete-file (format "~a.html" fn))
(unless (okay? result)
(printf "test ~s failed\n" n)
(printf " test code:")
(for-each (lambda (line) (printf " ~a\n" line)) line*)
(printf " result:\n ")
(if (condition? result)
(begin (display-condition result) (newline))
(parameterize ([pretty-initial-indent 4])
(pretty-print result)))
(newline))))))
(define-syntax returns
(syntax-rules ()
[(_ k) (lambda (x) (equal? x 'k))]))
(define-syntax oops
(syntax-rules ()
[(_ (c) e1 e2 ...)
(lambda (c) (and (condition? c) e1 e2 ...))]))
(test
'(
"1347"
)
(returns
(int (0 . 4) 1347)))
(test
'(
"3 /*"
)
(oops (c)
(equal? (condition-message c) "unexpected ~a at character ~s of ~a")
(equal? (condition-irritants c) '("eof" 6 "testfile2"))))
(test
'(
"3 / 4 + 5 opt(6)"
)
(oops (c)
(equal? (condition-message c) "parse error at or before character ~s of ~a")
(equal? (condition-irritants c) '(10 "testfile3"))))
(test
'(
"x = y = 5"
)
(returns
(=
(0 . 9)
(id (0 . 1) x)
(= (4 . 9) (id (4 . 5) y) (int (8 . 9) 5)))))
(test
'(
"x = y = x + 5 - z * 7 + 8 / z"
)
(returns
(=
(0 . 29)
(id (0 . 1) x)
(=
(4 . 29)
(id (4 . 5) y)
(+
(8 . 29)
(-
(8 . 21)
(+ (8 . 13) (id (8 . 9) x) (int (12 . 13) 5))
(* (16 . 21) (id (16 . 17) z) (int (20 . 21) 7)))
(/ (24 . 29) (int (24 . 25) 8) (id (28 . 29) z)))))))
(test
'(
"opt(opt(opt()))"
)
(returns
(OPT (0 . 15) (OPT (4 . 14) (OPT (8 . 13))))))
(test
'(
"kstar(3 4 kplus(1 2 3 kstar()))"
)
(returns
(K* (0 . 31)
(int (6 . 7) 3)
(int (8 . 9) 4)
(K+ (10 . 30)
(int (16 . 17) 1)
(int (18 . 19) 2)
(int (20 . 21) 3)
(K* (22 . 29))))))
(test
'(
"sepplus( opt() ; opt(5) ; sepstar(17, 34) ; sepstar())"
)
(returns
(SEP+ (0 . 54)
(OPT (9 . 14))
(OPT (17 . 23) (int (21 . 22) 5))
(SEP* (26 . 41) (int (34 . 36) 17) (int (38 . 40) 34))
(SEP* (44 . 53)))))
(delete-file "expr.md")
(printf "~s tests ran\n" n)
)
#!eof
The following should print only "<n> tests ran".
echo '(ez-grammar-test)' | ../bin/scheme -q ez-grammar-test.ss

759
ta6ob/examples/ez-grammar.ss Normal file
View file

@ -0,0 +1,759 @@
;;; Copyright 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.
;;; See http://www.cs.nott.ac.uk/~pszgmh/monparsing.pdf for origins of
;;; some of the monadic combinators.
;;; Authors: Jon Rossie, Kent Dybvig
;;; The define-grammar form produces a parser:
;;;
;;; parser : token-stream -> ((Tree token-stream) ...)
;;;
;;; If the return value is the empty list, a parse error occurred.
;;; If the return value has multiple elements, the parse was ambiguous.
;;; The token-stream in each (Tree token-stream) is the tail of the
;;; input stream that begins with the last token consumed by the parse.
;;; This gives the consumer access to both the first and last token,
;;; allowing it to determine cheaply the extent of the parse, including
;;; source locations if source information is attached to the tokens.
;;; Internally, backtracking occurs whenever a parser return value
;;; has multiple elements.
;;; This code should be included into a lexical context that supplies:
;;;
;;; token-bfp : token -> token's beginning file position
;;; token-efp : token -> token's ending file position
;;; meta constant? : syntax-object -> boolean
;;; sep->parser : sep -> parser
;;; constant->parser : constant -> parser
;;; make-src : bfp x efp -> src. bfp > efp => no tokens consumed.
;;;
;;; See ez-grammar-test.ss for an example.
(module (define-grammar
is sat item peek seq ++ +++ many many+ ?
parse-consumed-all? parse-result-value parse-result-unused
grammar-trace
)
(import (streams))
(define grammar-trace (make-parameter #f))
(define-record-type parse-result
(nongenerative parse-result)
(sealed #t)
(fields value unused))
;; to enable $trace-is to determine the ending file position (efp) of a parse
;; form, the input stream actually points to the preceding token rather than
;; to the current token. the next few routines establish, maintain, and deal
;; with that invariant.
(define make-top-level-parser
(lambda (parser)
(lambda (inp)
(parser (stream-cons 'dummy-token inp)))))
(define preceding-token
(lambda (inp)
(stream-car inp)))
(define current-token
(lambda (inp)
(stream-car (stream-cdr inp))))
(define remaining-tokens
(lambda (inp)
(stream-cdr inp)))
(define no-more-tokens?
(lambda (inp)
(stream-null? (stream-cdr inp))))
(define parse-consumed-all?
(lambda (res)
(no-more-tokens? (parse-result-unused res))))
;; A parser generator
(define result
(lambda (v)
;; this is a parser that ignores its input and produces v
(lambda (inp)
(stream (make-parse-result v inp)))))
;; A parse that always generates a parse error
(define zero
(lambda (inp)
stream-nil))
;; For a non-empty stream, successfully consume the first element
(define item
(lambda (inp)
(cond
[(no-more-tokens? inp) '()]
[else
(stream (make-parse-result (current-token inp) (remaining-tokens inp)))])))
(define (peek p)
(lambda (inp)
(stream-map (lambda (pr)
(make-parse-result (parse-result-value pr) inp))
(p inp))))
;;------------------------------------------
(define bind
(lambda (parser receiver)
(lambda (inp)
(let ([res* (parser inp)])
(stream-append-all
(stream-map (lambda (res)
((receiver (parse-result-value res))
(parse-result-unused res)))
res*))))))
;; monad comprehensions
(define-syntax is-where ; used by is and trace-is
(lambda (x)
(syntax-case x (where <-)
[(_ expr (where)) #'expr]
[(_ expr (where [x <- p] clauses ...))
#'(bind p (lambda (x) (is-where expr (where clauses ...))))]
[(_ expr (where pred clauses ...))
#'(if pred (is-where expr (where clauses ...)) zero)]
[(_ expr where-clause) (syntax-error #'where-clause)])))
(indirect-export is-where bind)
(define-syntax is
(syntax-rules ()
[(_ expr where-clause) (is-where (result expr) where-clause)]))
(indirect-export is is-where)
(module (trace-is)
(define ($trace-is name proc head)
(lambda (unused)
(let ([res (proc (token-bfp (current-token head)) (token-efp (preceding-token unused)))])
(when (and name (grammar-trace)) (printf "<<~s = ~s~%" name res))
(stream (make-parse-result res unused)))))
(define-syntax trace-is
(syntax-rules ()
[(_ name proc-expr where-clause)
(lambda (inp) ((is-where ($trace-is 'name proc-expr inp) where-clause) inp))]))
(indirect-export trace-is $trace-is))
(define (seq2 p q) (is (cons x y) (where [x <- p] [y <- q])))
(define seq
(lambda p*
(let loop ([p* p*])
(cond
[(null? p*) (result '())]
[else (seq2 (car p*) (loop (cdr p*)))]))))
(define (sat pred) (is x (where [x <- item] (pred x))))
(define ++ ;; introduce ambiguity
(lambda (p q)
(lambda (inp)
(stream-append2 (p inp)
(lambda ()
(q inp))))))
(define (many+ p) (is (cons x xs) (where [x <- p] [xs <- (many p)])))
(define (many p) (++ (many+ p) (result '())))
(define (? p) (++ (sat p) (result #f)))
(define (sepby1 p sep)
(is (cons x xs)
(where
[x <- p]
[xs <- (many (is y (where [_ <- sep] [y <- p])))])))
(define (sepby p sep) (++ (sepby1 p sep) (result '())))
(define (bracket open p close) (is x (where [_ <- open] [x <- p] [_ <- close])))
(define (optional p default)
(lambda (inp)
(let ([res (p inp)])
(if (stream-null? res)
(stream (make-parse-result default inp))
res))))
(define (first p)
(lambda (inp)
(let ([res (p inp)])
(if (stream-null? res)
res
(stream (stream-car res))))))
(define (+++ p q) (first (++ p q))) ;; choose first match, cut backtracking
(define-syntax infix-expression-parser
(lambda (x)
(syntax-case x ()
[(_ ((L/R ?op-parser) ...) ?term-parser ?receiver)
(with-syntax ([(op-parser ...) (generate-temporaries #'(?op-parser ...))])
#`(let ([op-parser ?op-parser] ... [term-parser (lambda (inp) (?term-parser inp))] [receiver ?receiver])
#,(let f ([ls #'((L/R op-parser) ...)])
(if (null? ls)
#'term-parser
#`(let ([next #,(f (cdr ls))])
#,(syntax-case (car ls) (LEFT RIGHT)
[(LEFT op-parser)
#'(let ()
(define-record-type frob (nongenerative) (sealed #t) (fields op y efp))
(trace-is binop-left (lambda (bfp ignore-this-efp)
(fold-left
(lambda (x f) (receiver bfp (frob-efp f) (frob-op f) x (frob-y f)))
x f*))
(where
[x <- next]
[f* <- (rec this
(optional
(is (cons f f*)
(where
[f <- (trace-is binop-left-tail (lambda (bfp efp) (make-frob op y efp))
(where
[op <- op-parser]
[y <- next]))]
[f* <- this]))
'()))])))]
[(RIGHT op-parser)
#'(rec this
(+++
(trace-is binop-right (lambda (bfp efp) (receiver bfp efp op x y))
(where
[x <- next]
[op <- op-parser]
[y <- this]))
next))]))))))])))
(define (format-inp inp)
(if (no-more-tokens? inp)
"#<null-stream>"
(format "(~s ...)" (current-token inp))))
(define-syntax define-grammar
(lambda (x)
(define-record-type grammar
(nongenerative)
(sealed #t)
(fields title paragraph* section*))
(define-record-type section
(nongenerative)
(sealed #t)
(fields title paragraph* suppressed? clause*))
(define-record-type clause
(nongenerative)
(fields id alias* before-paragraph* after-paragraph*))
(define-record-type regular-clause
(nongenerative)
(sealed #t)
(parent clause)
(fields prod*))
(define-record-type binop-clause
(nongenerative)
(sealed #t)
(parent clause)
(fields level* term receiver)
(protocol
(lambda (pargs->new)
(lambda (nt alias* before-paragraph* after-paragraph* level* term src? receiver)
((pargs->new nt alias* before-paragraph* after-paragraph*) level* term
#`(lambda (bfp efp op x y)
#,(if src?
#`(#,receiver (make-src bfp efp) op x y)
#`(#,receiver op x y))))))))
(define-record-type terminal-clause
(nongenerative)
(sealed #t)
(fields term*))
(define-record-type terminal
(nongenerative)
(sealed #t)
(fields parser alias* paragraph*))
(define-record-type production
(nongenerative)
(sealed #t)
(fields name paragraph* elt* receiver)
(protocol
(let ()
(define (check-elts elt*)
(for-each (lambda (elt) (unless (elt? elt) (errorf 'make-production "~s is not an elt" elt))) elt*))
(lambda (new)
(case-lambda
[(name elt* receiver)
(check-elts elt*)
(new name #f elt* receiver)]
[(name paragraph* elt* receiver)
(check-elts elt*)
(new name paragraph* elt* receiver)])))))
(define-record-type elt
(nongenerative))
(define-record-type sep-elt
(nongenerative)
(sealed #t)
(parent elt)
(fields +? elt sep))
(define-record-type opt-elt
(nongenerative)
(sealed #t)
(parent elt)
(fields elt default))
(define-record-type kleene-elt
(nongenerative)
(sealed #t)
(parent elt)
(fields +? elt))
(define-record-type constant-elt
(nongenerative)
(sealed #t)
(parent elt)
(fields k))
(define-record-type id-elt
(nongenerative)
(sealed #t)
(parent elt)
(fields id))
(define paragraph?
(lambda (x)
(syntax-case x (include)
[(include filename) (string? (datum filename))]
[(str ...) (andmap string? (datum (str ...)))])))
(define (gentemp) (datum->syntax #'* (gensym)))
(define (elt-temps elt*)
(for-each (lambda (elt) (unless (elt? elt) (errorf 'elt-temps "~s is not an elt" elt))) elt*)
(fold-left
(lambda (t* elt)
(if (constant-elt? elt) t* (cons (gentemp) t*)))
'()
elt*))
(define (left-factor clause*)
(define syntax-equal?
(lambda (x y)
(equal? (syntax->datum x) (syntax->datum y))))
(define (elt-equal? x y)
(cond
[(sep-elt? x)
(and (sep-elt? y)
(eq? (sep-elt-+? x) (sep-elt-+? y))
(elt-equal? (sep-elt-elt x) (sep-elt-elt y))
(syntax-equal? (sep-elt-sep x) (sep-elt-sep y)))]
[(opt-elt? x)
(and (opt-elt? y)
(elt-equal? (opt-elt-elt x) (opt-elt-elt y))
(syntax-equal? (opt-elt-default x) (opt-elt-default y)))]
[(kleene-elt? x)
(and (kleene-elt? y)
(eq? (kleene-elt-+? x) (kleene-elt-+? y))
(elt-equal? (kleene-elt-elt x) (kleene-elt-elt y)))]
[(constant-elt? x)
(and (constant-elt? y)
(syntax-equal? (constant-elt-k x) (constant-elt-k y)))]
[(id-elt? x)
(and (id-elt? y)
(syntax-equal? (id-elt-id x) (id-elt-id y)))]
[else #f]))
(let lp1 ([clause* clause*] [new-clause* '()])
(if (null? clause*)
(reverse new-clause*)
(let ([clause (car clause*)])
(let lp2 ([prod* (regular-clause-prod* clause)] [new-prod* '()] [clause* (cdr clause*)])
(if (null? prod*)
(lp1 clause* (cons (make-regular-clause (clause-id clause) (clause-alias* clause) '() '() (reverse new-prod*)) new-clause*))
(let ([prod (car prod*)] [prod* (cdr prod*)])
(let ([elt* (production-elt* prod)])
(if (null? elt*)
(lp2 prod* (cons prod new-prod*) clause*)
(let ([elt (car elt*)])
(let-values ([(haves have-nots) (partition
(lambda (prod)
(let ([elt* (production-elt* prod)])
(and (not (null? elt*))
(elt-equal? (car elt*) elt))))
prod*)])
(if (null? haves)
(lp2 prod* (cons prod new-prod*) clause*)
(let ([haves (cons prod haves)])
; "haves" start with the same elt. to cut down on the number of new
; nonterminals and receiver overhead, find the largest common prefix
(let ([prefix (cons elt
(let f ([elt** (map production-elt* haves)])
(let ([elt** (map cdr elt**)])
(if (ormap null? elt**)
'()
(let ([elt (caar elt**)])
(if (andmap (lambda (elt*) (elt-equal? (car elt*) elt)) (cdr elt**))
(cons elt (f elt**))
'()))))))])
(let ([t (gentemp)] [n (length prefix)] [t* (elt-temps prefix)])
(lp2 have-nots
(cons (make-production #f (append prefix (list (make-id-elt t)))
#`(lambda (bfp efp #,@t* p) (p bfp #,@t*)))
new-prod*)
(cons (make-regular-clause t '() '() '()
(map (lambda (prod)
(let ([elt* (list-tail (production-elt* prod) n)])
(make-production (production-name prod) elt*
(let ([u* (elt-temps elt*)])
#`(lambda (bfp efp #,@u*)
(lambda (bfp #,@t*)
(#,(production-receiver prod) bfp efp #,@t* #,@u*)))))))
haves))
clause*)))))))))))))))))
(define (make-env tclause* clause*)
(let ([env (make-hashtable (lambda (x) (symbol-hash (syntax->datum x))) free-identifier=?)])
(define (insert parser)
(lambda (name)
(let ([a (hashtable-cell env name #f)])
(when (cdr a) (syntax-error name "duplicate terminal/non-terminal name"))
(set-cdr! a parser))))
(for-each
(lambda (tclause)
(for-each
(lambda (term)
(let ([parser (terminal-parser term)])
(for-each (insert parser) (cons parser (terminal-alias* term)))))
(terminal-clause-term* tclause)))
tclause*)
(for-each
(lambda (clause)
(let ([id (clause-id clause)])
(for-each (insert id) (cons id (clause-alias* clause)))))
clause*)
env))
(define (lookup id env)
(or (hashtable-ref env id #f)
(syntax-error id "unrecognized terminal or nonterminal")))
(define (render-markdown name grammar mdfn env)
(define (separators sep ls)
(if (null? ls)
""
(apply string-append
(cons (car ls)
(map (lambda (s) (format "~a~a" sep s)) (cdr ls))))))
(define (render-paragraph hard-leading-newline?)
(lambda (paragraph)
(define (md-text s)
(list->string
(fold-right
(lambda (c ls)
(case c
[(#\\) (cons* c c ls)]
[else (cons c ls)]))
'()
(string->list s))))
(syntax-case paragraph (include)
[(include filename)
(string? (datum filename))
(let ([text (call-with-port (open-input-file (datum filename)) get-string-all)])
(unless (equal? text "")
(if hard-leading-newline? (printf "\\\n") (newline))
(display-string text)))]
[(sentence ...)
(andmap string? (datum (sentence ...)))
(let ([sentence* (datum (sentence ...))])
(unless (null? sentence*)
(if hard-leading-newline? (printf "\\\n") (newline))
(printf "~a\n" (separators " " (map md-text sentence*)))))])))
(define (format-elt x)
(cond
[(sep-elt? x)
(let* ([one (format-elt (sep-elt-elt x))]
[sep (constant->markdown (syntax->datum (sep-elt-sep x)))]
[seq (format "~a&nbsp;&nbsp;~a&nbsp;&nbsp;`...`" one sep)])
(if (sep-elt-+? x)
seq
(format "OPT(~a)" seq)))]
[(opt-elt? x)
(format "~a~~opt~~" (format-elt (opt-elt-elt x)))]
[(kleene-elt? x)
(let ([one (format-elt (kleene-elt-elt x))])
(if (kleene-elt-+? x)
(format "~a&nbsp;&nbsp;`...`" one)
(format "OPT(~a)" one)))]
[(constant-elt? x) (constant->markdown (syntax->datum (constant-elt-k x)))]
[(id-elt? x) (format "[*~s*](#~s)"
(syntax->datum (id-elt-id x))
(syntax->datum (lookup (id-elt-id x) env)))]
[else (errorf 'format-elt "unexpected elt ~s" x)]))
(define (render-elt x)
(printf "&nbsp;&nbsp;~a" (format-elt x)))
(define (render-production prod)
(unless (null? (production-elt* prod))
(printf " : ")
(for-each render-elt (production-elt* prod))
(printf "\n"))
(when (and (null? (production-elt* prod))
(not (null? (production-paragraph* prod))))
(errorf 'render-production "empty production must not have description: ~a" (production-paragraph* prod)))
(for-each (render-paragraph #t) (production-paragraph* prod)))
(define (render-clause clause)
(define (render-aliases alias*)
(unless (null? alias*)
(printf " \naliases: ~{*~a*~^, ~}\n" (map syntax->datum alias*))))
(if (terminal-clause? clause)
(for-each
(lambda (term)
(printf "\n#### *~a* {#~:*~a}\n" (syntax->datum (terminal-parser term)))
(render-aliases (terminal-alias* term))
(for-each (render-paragraph #f) (terminal-paragraph* term)))
(terminal-clause-term* clause))
(let ([id (syntax->datum (clause-id clause))])
(printf "\n#### *~a* {#~:*~a}\n" id)
(render-aliases (clause-alias* clause))
(for-each (render-paragraph #f) (clause-before-paragraph* clause))
(printf "\nsyntax:\n")
(if (binop-clause? clause)
(let ([level* (binop-clause-level* clause)])
(let loop ([level* level*] [first? #t])
(unless (null? level*)
(let ([level (syntax->datum (car level*))] [level* (cdr level*)])
(let ([L/R (car level)] [op* (cdr level)])
(printf " : _~(~a~)-associative" L/R)
(if first?
(if (null? level*)
(printf ":_\n")
(printf ", highest precedence:_\n"))
(if (null? level*)
(printf ", lowest precedence:_\n")
(printf ":_\n")))
(for-each
(lambda (op) (printf " : ~s ~a ~s\n" id (constant->markdown op) id))
op*))
(loop level* #f))))
(printf " : _leaves:_\n")
(printf " : ")
(render-elt (binop-clause-term clause))
(printf "\n"))
(for-each render-production (or (regular-clause-prod* clause) '())))
(for-each (render-paragraph #f) (clause-after-paragraph* clause)))))
(define (render-section section)
(unless (section-suppressed? section)
(printf "\n## ~a\n" (or (section-title section) "The section"))
(for-each (render-paragraph #f) (section-paragraph* section))
(for-each render-clause (section-clause* section))))
(with-output-to-file mdfn
(lambda ()
(printf "# ~a\n" (or (grammar-title grammar) "The grammar"))
(for-each (render-paragraph #f) (grammar-paragraph* grammar))
(for-each render-section (grammar-section* grammar)))
'replace))
(module (parse-grammar)
(define parse-elt
(lambda (elt)
(syntax-case elt (SEP+ SEP* OPT K* K+)
[(SEP+ p sep) (make-sep-elt #t (parse-elt #'p) #'sep)]
[(SEP* p sep) (make-sep-elt #f (parse-elt #'p) #'sep)]
[(OPT p default) (make-opt-elt (parse-elt #'p) #'default)]
[(K+ p) (make-kleene-elt #t (parse-elt #'p))]
[(K* p) (make-kleene-elt #f (parse-elt #'p))]
[k (constant? #'k) (make-constant-elt #'k)]
[id (identifier? #'id) (make-id-elt #'id)]
[_ (syntax-error elt "invalid production element")])))
(define parse-production
(lambda (prod)
(define (finish name src? paragraph* elt* receiver)
(let ([elt* (map parse-elt elt*)])
(make-production name paragraph* elt*
(with-syntax ([(t ...) (elt-temps elt*)])
#`(lambda (bfp efp t ...)
#,(if src?
#`(#,receiver (make-src bfp efp) t ...)
#`(#,receiver t ...)))))))
(syntax-case prod (:: src =>)
[[name :: src elt ... => receiver]
(finish #'name #t '() #'(elt ...) #'receiver)]
[[name :: elt ... => receiver]
(finish #'name #f '() #'(elt ...) #'receiver)])))
(define (parse-terminal term)
(syntax-case term (DESCRIPTION)
[(parser (alias ...) (DESCRIPTION paragraph ...))
(and (identifier? #'parser) (andmap identifier? #'(alias ...)) (andmap paragraph? #'(paragraph ...)))
(make-terminal #'parser #'(alias ...) #'(paragraph ...))]
[(parser (alias ...))
(and (identifier? #'parser) (andmap identifier? #'(alias ...)))
(make-terminal #'parser #'(alias ...) '())]))
(define (parse-clause clause nt alias* before-paragraph* after-paragraph* stuff*)
(syntax-case stuff* (BINOP :: src =>)
[((BINOP src (level ...) term) => receiver)
(make-binop-clause nt alias* before-paragraph* after-paragraph* #'(level ...) (parse-elt #'term) #t #'receiver)]
[((BINOP (level ...) term) => receiver)
(make-binop-clause nt alias* before-paragraph* after-paragraph* #'(level ...) (parse-elt #'term) #f #'receiver)]
[(prod prods ...)
(make-regular-clause nt alias* before-paragraph* after-paragraph* (map parse-production #'(prod prods ...)))]
[else (syntax-error clause)]))
(define (parse-top top* knull kgrammar ksection kclause)
(if (null? top*)
(knull)
(let ([top (car top*)] [top* (cdr top*)])
(syntax-case top (GRAMMAR SECTION SUPPRESSED DESCRIPTION BINOP TERMINALS src =>)
[(GRAMMAR title paragraph ...)
(andmap paragraph? #'(paragraph ...))
(kgrammar top* (datum title) #'(paragraph ...))]
[(SECTION SUPPRESSED title paragraph ...)
(andmap paragraph? #'(paragraph ...))
(ksection top* (datum title) #'(paragraph ...) #t)]
[(SECTION title paragraph ...)
(andmap paragraph? #'(paragraph ...))
(ksection top* (datum title) #'(paragraph ...) #f)]
[(TERMINALS term ...)
(kclause top* (make-terminal-clause (map parse-terminal #'(term ...))))]
[(TERMINALS term ...)
(kclause top* (make-terminal-clause (map parse-terminal #'(term ...))))]
[(nt (alias ...) (DESCRIPTION paragraph1 ...) stuff ... (DESCRIPTION paragraph2 ...))
(and (identifier? #'nt) (andmap identifier? #'(alias ...)) (andmap paragraph? #'(paragraph1 ...)) (andmap paragraph? #'(paragraph2 ...)))
(kclause top* (parse-clause top #'nt #'(alias ...) #'(paragraph1 ...) #'(paragraph2 ...) #'(stuff ...)))]
[(nt (alias ...) (DESCRIPTION paragraph ...) stuff ...)
(and (identifier? #'nt) (andmap identifier? #'(alias ...)) (andmap paragraph? #'(paragraph ...)))
(kclause top* (parse-clause top #'nt #'(alias ...) #'(paragraph ...) '() #'(stuff ...)))]
[(nt (alias ...) stuff ... (DESCRIPTION paragraph ...))
(and (identifier? #'nt) (andmap identifier? #'(alias ...)) (andmap paragraph? #'(paragraph ...)))
(kclause top* (parse-clause top #'nt #'(alias ...) '() #'(paragraph ...) #'(stuff ...)))]
[(nt (alias ...) stuff ...)
(and (identifier? #'nt) (andmap identifier? #'(alias ...)))
(kclause top* (parse-clause top #'nt #'(alias ...) '() '() #'(stuff ...)))]))))
(define (parse-grammar top*)
(define (misplaced-grammar-error top)
(syntax-error top "unexpected GRAMMAR element after other elements"))
(define (s1 top*) ; looking for GRAMMAR form, first SECTION form, or clause
(parse-top top*
(lambda () (make-grammar #f '() '()))
(lambda (top* title paragraph*)
(make-grammar title paragraph* (s2 top*)))
(lambda (top* title paragraph* suppressed?)
(make-grammar #f '()
(s3 top* title paragraph* suppressed? '() '())))
(lambda (top* clause)
(make-grammar #f '()
(s3 top* #f '() #f (list clause) '())))))
(define (s2 top*) ; looking for first SECTION form or clause
(parse-top top*
(lambda () '())
(lambda (title paragraph*) (misplaced-grammar-error (car top*)))
(lambda (top* title paragraph* suppressed?)
(s3 top* title paragraph* suppressed? '() '()))
(lambda (top* clause)
(s3 top* #f '() #f (list clause) '()))))
(define (s3 top* title paragraph* suppressed? rclause* rsection*) ; steady state: looking for remaining SECTION forms and clauses
(define (finish-section)
(cons (make-section title paragraph* suppressed? (reverse rclause*)) rsection*))
(parse-top top*
(lambda () (reverse (finish-section)))
(lambda (title paragraph*) (misplaced-grammar-error (car top*)))
(lambda (top* title paragraph* suppressed?)
(s3 top* title paragraph* suppressed? '() (finish-section)))
(lambda (top* clause)
(s3 top* title paragraph* suppressed? (cons clause rclause*) rsection*))))
(s1 top*)))
(define (go init-nts top* mddir)
(let ([grammar (parse-grammar top*)])
(let* ([clause* (apply append (map section-clause* (grammar-section* grammar)))]
[terminal-clause* (filter terminal-clause? clause*)]
[binop-clause* (filter binop-clause? clause*)]
[regular-clause* (left-factor (filter regular-clause? clause*))]
[env (make-env terminal-clause* (append binop-clause* regular-clause*))])
(define (elt-helper x)
(cond
[(sep-elt? x) #`(#,(if (sep-elt-+? x) #'sepby1 #'sepby) #,(elt-helper (sep-elt-elt x)) (sep->parser #,(sep-elt-sep x)))]
[(opt-elt? x) #`(optional #,(elt-helper (opt-elt-elt x)) #,(opt-elt-default x))]
[(kleene-elt? x) #`(#,(if (kleene-elt-+? x) #'many+ #'many) #,(elt-helper (kleene-elt-elt x)))]
[(constant-elt? x) #`(constant->parser '#,(constant-elt-k x))]
[(id-elt? x) (lookup (id-elt-id x) env)]
[else (errorf 'elt-helper "unhandled elt ~s\n" x)]))
(define (binop-helper clause)
#`[#,(clause-id clause)
(infix-expression-parser
#,(map (lambda (level)
(syntax-case level ()
[(L/R op1 ... op2)
(or (free-identifier=? #'L/R #'LEFT) (free-identifier=? #'L/R #'RIGHT))
#`(L/R #,(fold-right (lambda (op next) #`(++ (binop->parser '#,op) #,next)) #'(binop->parser 'op2) #'(op1 ...)))]))
(binop-clause-level* clause))
#,(elt-helper (binop-clause-term clause))
#,(binop-clause-receiver clause))])
(define (nt-helper clause)
#`[#,(clause-id clause)
#,(let f ([prod* (regular-clause-prod* clause)])
(if (null? prod*)
#'zero
(let ([elt* (production-elt* (car prod*))])
(with-syntax ([name (production-name (car prod*))]
[(elt ...) elt*]
[receiver (production-receiver (car prod*))])
(with-syntax ([(x ...) (generate-temporaries elt*)])
(with-syntax ([([y _] ...) (filter (lambda (pr) (not (constant-elt? (cadr pr)))) #'([x elt] ...))])
(with-syntax ([(where-nt ...) (map elt-helper elt*)])
#`(+++ ;; use +++ if you don't ever need to backtrack to a previous production for the same non-terminal
(lambda (inp)
(when (and 'name (grammar-trace)) (printf ">>~s(~a)~%" 'name (format-inp inp)))
(let ([res ((trace-is name (lambda (bfp efp) (receiver bfp efp y ...)) (where [x <- where-nt] ...)) inp)])
(when (and 'name (grammar-trace))
(if (stream-null? res)
(printf "<<~s(~a) failed~%" 'name (format-inp inp))
(printf "<<~s(~a) succeeded~%" 'name (format-inp inp))))
res))
#,(f (cdr prod*))))))))))])
(with-syntax ([(init-nt ...)
(syntax-case init-nts ()
[(id1 id2 ...) (andmap identifier? #'(id1 id2 ...)) #'(id1 id2 ...)]
[id (identifier? #'id) (list #'id)])])
(when mddir
(for-each
(lambda (init-nt)
(let ([mdfn (format "~a/~a.md" mddir (syntax->datum init-nt))])
(render-markdown init-nt grammar mdfn env)))
#'(init-nt ...)))
(with-syntax ([((lhs rhs) ...)
(append
(map binop-helper binop-clause*)
(map nt-helper regular-clause*))])
#'(module (init-nt ...)
(module M (init-nt ...) (define lhs rhs) ...)
(define init-nt
(let ()
(import M)
(make-top-level-parser init-nt)))
...))))))
(syntax-case x (markdown-directory)
[(_ init-nts (markdown-directory mddir) top ...)
(string? (datum mddir))
(go #'init-nts #'(top ...) (datum mddir))]
[(_ init-nts top ...) (go #'init-nts #'(top ...) #f)])))
(indirect-export define-grammar
result
zero
is
trace-is
sepby1
sepby
optional
many
many+
+++
infix-expression-parser
grammar-trace
format-inp
trace-is
make-top-level-parser
)
)

Some files were not shown because too many files have changed in this diff Show more