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

feat: 9.5.9

Browse source
This commit is contained in:
tmtt 2022-07-29 15:12:07 +02:00
parent cb1753732b
commit 35f43a7909
1084 changed files with 558985 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

154
c/Makefile.a6nt Normal file
View file

@ -0,0 +1,154 @@
# Makefile.a6nt
# 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 = a6nt
# following have to use \ for directory separator
SchemeInclude = ..\boot\$m
KernelDll = ..\bin\$m\csv959.dll
KernelLib = ..\bin\$m\csv959.lib
MTKernelLib = ..\boot\$m\csv959mt.lib
MDKernelLib = ..\boot\$m\csv959md.lib
KernelExp = ..\bin\$m\csv959.exp
Exec = ..\bin\$m\scheme.exe
MTMain = ..\boot\$m\mainmt.obj
MDMain = ..\boot\$m\mainmd.obj
ResFile = ..\boot\$m\scheme.res
# We use MD so that we can link with and load DLLs built against msvcrxxx.dll
CFLAGS=/nologo /Ox /W3 /Zi /I$(SchemeInclude) /I..\zlib /I..\lz4\lib /DX86_64 /DWIN32 /D_CRT_SECURE_NO_WARNINGS
MDCFLAGS=$(CFLAGS) /MD
MTCFLAGS=$(CFLAGS) /MT
DLLLDFLAGS=/debug:full /machine:X64 /nologo
# stack limit is 1MB by default. this is not enough for one of the mats in foreign.ms, which
# builds up nested C & Scheme stack frames. 2MB seems to be enough, but we set to 16MB.
EXELDFLAGS=/debug:full /machine:X64 /incremental:no /nologo /STACK:0x1000000
# use following flags for debugging
# CFLAGS=/nologo /Od /W3 /Zi /I$(SchemeInclude) /I..\zlib /I..\lz4\lib /DX86_64 /DWIN32 /D_CRT_SECURE_NO_WARNINGS
# MDCFLAGS=$(CFLAGS) /MDd
# MTCFLAGS=$(CFLAGS) /MTd
SystemLib=rpcrt4.lib ole32.lib advapi32.lib User32.lib
MDZlibLib=..\zlib\zlib.lib
MTZlibLib=..\zlib\zlibmt.lib
MDLZ4Lib=..\lz4\lib\liblz4.lib
MTLZ4Lib=..\lz4\lib\liblz4mt.lib
csrc=statics.c segment.c alloc.c symbol.c intern.c gcwrapper.c gc-011.c gc-oce.c gc-ocd.c\
number.c schsig.c io.c new-io.c print.c fasl.c stats.c\
foreign.c prim.c prim5.c flushcache.c\
windows.c\
schlib.c thread.c expeditor.c scheme.c compress-io.c
cobj=statics.obj segment.obj alloc.obj symbol.obj intern.obj gcwrapper.obj gc-011.obj gc-oce.obj gc-ocd.obj\
number.obj schsig.obj io.obj new-io.obj print.obj fasl.obj stats.obj\
foreign.obj prim.obj prim5.obj flushcache.obj\
windows.obj\
schlib.obj thread.obj expeditor.obj scheme.obj compress-io.obj
hsrc=system.h types.h version.h globals.h externs.h compress-io.h segment.h gc.c thread.h sort.h itest.c
.SUFFIXES:
all: $(Exec) $(MTKernelLib) $(MDKernelLib) $(MTMain)
$(KernelLib) $(MTKernelLib) $(MDKernelLib): $(hsrc)
$(KernelLib) $(MTKernelLib) $(MDKernelLib): $(SchemeInclude)/equates.h $(SchemeInclude)/scheme.h
$(KernelLib) $(MTKernelLib) $(MDKernelLib): ..\zlib/zconf.h ..\zlib/zlib.h
$(KernelLib) $(MTKernelLib) $(MDKernelLib): ../lz4/lib/lz4.h ../lz4/lib/lz4frame.h
$(MTKernelLib): $(csrc) $(MTZlibLib) $(MTLZ4Lib) a6nt-jump.obj
-del /f $(MTKernelLib)
cl /DSCHEME_STATIC /c $(MTCFLAGS) $(csrc)
link /lib /nologo -out:$(MTKernelLib) $(cobj) $(MTZlibLib) $(MTLZ4Lib) a6nt-jump.obj
$(MDKernelLib): $(csrc) $(MDZlibLib) $(MDLZ4Lib) a6nt-jump.obj
-del /f $(MDKernelLib)
cl /DSCHEME_STATIC /c $(MDCFLAGS) $(csrc)
link /lib /nologo -out:$(MDKernelLib) $(cobj) $(MDZlibLib) $(MDLZ4Lib) a6nt-jump.obj
# nmake builds Dll twice if we list it with $(KernelLib) below
$(KernelDll): $(KernelLib)
# base chosen to be consistent with "microsoft conventions"
# http://www.windevnet.com/documents/s=7482/win1078945937961/
# but set at a basically odd address to reduce likelihood of
# conflicts with other dlls. use 'depends <exefile>' to check.
# we no longer attempt to rebase other the CRT dll since it
# has already been signed.
$(KernelLib): $(ResFile) $(csrc) $(MDZlibLib) $(MDLZ4Lib) a6nt-jump.obj
-del /f $(KernelLib)
-del /f $(KernelDll)
cl /c $(MDCFLAGS) $(csrc)
link -dll -out:$(KernelDll) $(DLLLDFLAGS) $(ResFile) $(cobj) $(MDZlibLib) $(MDLZ4Lib) $(SystemLib) a6nt-jump.obj
editbin /nologo /rebase:base=0x67480000 $(KernelDll)
$(MTMain): main.c
-del /f $(MTMain)
cl /DSCHEME_STATIC /c $(MTCFLAGS) main.c
copy main.obj $(MTMain)
$(MDMain): main.c
-del /f $(MDMain)
cl /c $(MDCFLAGS) main.c
copy main.obj $(MDMain)
$(Exec): $(ResFile) $(MDMain) $(KernelLib)
-del /f $(Exec)
link /out:$(Exec) $(EXELDFLAGS) $(ResFile) $(MDMain) $(KernelLib)
mt -manifest ..\..\c\scheme.exe.manifest -outputresource:$(Exec);1
$(ResFile): scheme.rc
-del /f $(ResFile)
rc -r /fo $(ResFile) -DWIN32 scheme.rc
# for testing mt kernel and mainmt.obj:
mtscheme.exe: $(ResFile) $(MTMain) $(MTKernelLib)
-del /f mtscheme.exe
link /out:mtscheme.exe $(EXELDFLAGS) $(ResFile) $(MTMain) $(MTKernelLib) $(SystemLib)
# for testing md kernel and mainmd.obj:
mdscheme.exe: $(ResFile) $(MDMain) $(MDKernelLib)
-del /f mdscheme.exe
link /out:mdscheme.exe $(EXELDFLAGS) $(ResFile) $(MDMain) $(MDKernelLib) $(SystemLib)
..\zlib\zlib.h ..\zlib\zconf.h $(MDZlibLib) $(MTZlibLib):
cd ../zlib
nmake /nologo -f win32/Makefile.msc AR="link /lib" CFLAGS="-nologo -MT -O2 $(LOC)"
ren zlib.lib zlibmt.lib
nmake /nologo -f win32/Makefile.msc clean
nmake /nologo -f win32/Makefile.msc AR="link /lib"
cd ../c
$(MDLZ4Lib) $(MTLZ4Lib): ../lz4/lib/lz4.c ../lz4/lib/lz4frame.c ../lz4/lib/lz4hc.c
cl /c /Fo../lz4/lib/lz4.obj $(MDCFLAGS) ../lz4/lib/lz4.c
cl /c /Fo../lz4/lib/lz4frame.obj $(MDCFLAGS) ../lz4/lib/lz4frame.c
cl /c /Fo../lz4/lib/lz4hc.obj $(MDCFLAGS) ../lz4/lib/lz4hc.c
cl /c /Fo../lz4/lib/xxhash.obj $(MDCFLAGS) ../lz4/lib/xxhash.c
lib /OUT:$(MDLZ4Lib) ../lz4/lib/lz4.obj ../lz4/lib/lz4frame.obj ../lz4/lib/lz4hc.obj ../lz4/lib/xxhash.obj
cl /c /Fo../lz4/lib/lz4mt.obj $(MTCFLAGS) ../lz4/lib/lz4.c
cl /c /Fo../lz4/lib/lz4framemt.obj $(MTCFLAGS) ../lz4/lib/lz4frame.c
cl /c /Fo../lz4/lib/lz4hcmt.obj $(MTCFLAGS) ../lz4/lib/lz4hc.c
cl /c /Fo../lz4/lib/xxhashmt.obj $(MTCFLAGS) ../lz4/lib/xxhash.c
lib /OUT:$(MTLZ4Lib) ../lz4/lib/lz4mt.obj ../lz4/lib/lz4framemt.obj ../lz4/lib/lz4hcmt.obj ../lz4/lib/xxhashmt.obj
a6nt-jump.obj: a6nt-jump.asm
ml64 /nologo /W3 /Zi /c a6nt-jump.asm
clean:
-del /f $(cobj) main.obj $(KernelExp) a6nt-jump.obj
-del /f mtscheme.exe
-del /f mdscheme.exe

150
c/Makefile.i3nt Normal file
View file

@ -0,0 +1,150 @@
# Makefile.i3nt
# 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 = i3nt
# following have to use \ for directory separator
SchemeInclude = ..\boot\$m
KernelDll = ..\bin\$m\csv959.dll
KernelLib = ..\bin\$m\csv959.lib
MTKernelLib = ..\boot\$m\csv959mt.lib
MDKernelLib = ..\boot\$m\csv959md.lib
KernelExp = ..\bin\$m\csv959.exp
Exec = ..\bin\$m\scheme.exe
MTMain = ..\boot\$m\mainmt.obj
MDMain = ..\boot\$m\mainmd.obj
ResFile = ..\boot\$m\scheme.res
# We use MD so that we can link with and load DLLs built against msvcrxxx.dll
CFLAGS=/nologo /fp:precise /Ox /W3 /Zi /I$(SchemeInclude) /I..\zlib /I..\lz4\lib /DI386 /DWIN32 /D_CRT_SECURE_NO_WARNINGS
MDCFLAGS=$(CFLAGS) /MD
MTCFLAGS=$(CFLAGS) /MT
DLLLDFLAGS=/debug:full /machine:ix86 /nologo
# see note in Makefile.a6nt regarding stack size. we use 8MB here to be consistent.
EXELDFLAGS=/debug:full /machine:ix86 /incremental:no /nologo /STACK:0x800000
# use following flags for debugging
# CFLAGS=/nologo /fp:precise /Od /W3 /Zi /I$(SchemeInclude) /I..\zlib /I..\lz4\lib /DI386 /DWIN32 /D_CRT_SECURE_NO_WARNINGS
# MDCFLAGS=$(CFLAGS) /MDd
# MTCFLAGS=$(CFLAGS) /MTd
SystemLib=rpcrt4.lib ole32.lib advapi32.lib User32.lib
MDZlibLib=..\zlib\zlib.lib
MTZlibLib=..\zlib\zlibmt.lib
MDLZ4Lib=..\lz4\lib\liblz4.lib
MTLZ4Lib=..\lz4\lib\liblz4mt.lib
csrc=statics.c segment.c alloc.c symbol.c intern.c gcwrapper.c gc-011.c gc-oce.c gc-ocd.c\
number.c schsig.c io.c new-io.c print.c fasl.c stats.c\
foreign.c prim.c prim5.c flushcache.c\
windows.c\
schlib.c thread.c expeditor.c scheme.c compress-io.c
cobj=statics.obj segment.obj alloc.obj symbol.obj intern.obj gcwrapper.obj gc-011.obj gc-oce.obj gc-ocd.obj\
number.obj schsig.obj io.obj new-io.obj print.obj fasl.obj stats.obj\
foreign.obj prim.obj prim5.obj flushcache.obj\
windows.obj\
schlib.obj thread.obj expeditor.obj scheme.obj compress-io.obj
hsrc=system.h types.h version.h globals.h externs.h compress-io.h segment.h gc.c thread.h sort.h itest.c
.SUFFIXES:
all: $(Exec) $(MTKernelLib) $(MDKernelLib) $(MTMain)
$(KernelLib) $(MTKernelLib) $(MDKernelLib): $(hsrc)
$(KernelLib) $(MTKernelLib) $(MDKernelLib): $(SchemeInclude)/equates.h $(SchemeInclude)/scheme.h
$(KernelLib) $(MTKernelLib) $(MDKernelLib): ..\zlib/zconf.h ..\zlib/zlib.h
$(KernelLib) $(MTKernelLib) $(MDKernelLib): ../lz4/lib/lz4.h ../lz4/lib/lz4frame.h
$(MTKernelLib): $(csrc) $(MTZlibLib) $(MTLZ4Lib)
-del /f $(MTKernelLib)
cl /DSCHEME_STATIC /c $(MTCFLAGS) $(csrc)
link /lib /nologo -out:$(MTKernelLib) $(cobj) $(MTZlibLib) $(MTLZ4Lib)
$(MDKernelLib): $(csrc) $(MDZlibLib) $(MDLZ4Lib)
-del /f $(MDKernelLib)
cl /DSCHEME_STATIC /c $(MDCFLAGS) $(csrc)
link /lib /nologo -out:$(MDKernelLib) $(cobj) $(MDZlibLib) $(MDLZ4Lib)
# nmake builds Dll twice if we list it with $(KernelLib) below
$(KernelDll): $(KernelLib)
# base chosen to be consistent with "microsoft conventions"
# http://www.windevnet.com/documents/s=7482/win1078945937961/
# but set at a basically odd address to reduce likelihood of
# conflicts with other dlls. use 'depends <exefile>' to check.
# we no longer attempt to rebase other the CRT dll since it
# has already been signed.
$(KernelLib): $(ResFile) $(csrc) $(MDZlibLib) $(MDLZ4Lib)
-del /f $(KernelLib)
-del /f $(KernelDll)
cl /c $(MDCFLAGS) $(csrc)
link -dll -out:$(KernelDll) $(DLLLDFLAGS) $(ResFile) $(cobj) $(MDZlibLib) $(MDLZ4Lib) $(SystemLib)
editbin /nologo /rebase:base=0x67480000 $(KernelDll)
$(MTMain): main.c
-del /f $(MTMain)
cl /DSCHEME_STATIC /c $(MTCFLAGS) main.c
copy main.obj $(MTMain)
$(MDMain): main.c
-del /f $(MDMain)
cl /c $(MDCFLAGS) main.c
copy main.obj $(MDMain)
$(Exec): $(ResFile) $(MDMain) $(KernelLib)
-del /f $(Exec)
link /out:$(Exec) $(EXELDFLAGS) $(ResFile) $(MDMain) $(KernelLib)
mt -manifest ..\..\c\scheme.exe.manifest -outputresource:$(Exec);1
$(ResFile): scheme.rc
-del /f $(ResFile)
rc -r /fo $(ResFile) -DWIN32 scheme.rc
# for testing mt kernel and mainmt.obj:
mtscheme.exe: $(ResFile) $(MTMain) $(MTKernelLib)
-del /f mtscheme.exe
link /out:mtscheme.exe $(EXELDFLAGS) $(ResFile) $(MTMain) $(MTKernelLib) $(SystemLib)
# for testing md kernel and mainmd.obj:
mdscheme.exe: $(ResFile) $(MDMain) $(MDKernelLib)
-del /f mdscheme.exe
link /out:mdscheme.exe $(EXELDFLAGS) $(ResFile) $(MDMain) $(MDKernelLib) $(SystemLib)
..\zlib\zlib.h ..\zlib\zconf.h $(MDZlibLib) $(MTZlibLib):
cd ../zlib
nmake /nologo -f win32/Makefile.msc AR="link /lib" CFLAGS="-nologo -MT -O2 $(LOC)"
ren zlib.lib zlibmt.lib
nmake /nologo -f win32/Makefile.msc clean
nmake /nologo -f win32/Makefile.msc AR="link /lib"
cd ../c
$(MDLZ4Lib) $(MTLZ4Lib): ../lz4/lib/lz4.c ../lz4/lib/lz4frame.c ../lz4/lib/lz4hc.c
cl /c /Fo../lz4/lib/lz4.obj $(MDCFLAGS) ../lz4/lib/lz4.c
cl /c /Fo../lz4/lib/lz4frame.obj $(MDCFLAGS) ../lz4/lib/lz4frame.c
cl /c /Fo../lz4/lib/lz4hc.obj $(MDCFLAGS) ../lz4/lib/lz4hc.c
cl /c /Fo../lz4/lib/xxhash.obj $(MDCFLAGS) ../lz4/lib/xxhash.c
lib /OUT:$(MDLZ4Lib) ../lz4/lib/lz4.obj ../lz4/lib/lz4frame.obj ../lz4/lib/lz4hc.obj ../lz4/lib/xxhash.obj
cl /c /Fo../lz4/lib/lz4mt.obj $(MTCFLAGS) ../lz4/lib/lz4.c
cl /c /Fo../lz4/lib/lz4framemt.obj $(MTCFLAGS) ../lz4/lib/lz4frame.c
cl /c /Fo../lz4/lib/lz4hcmt.obj $(MTCFLAGS) ../lz4/lib/lz4hc.c
cl /c /Fo../lz4/lib/xxhashmt.obj $(MTCFLAGS) ../lz4/lib/xxhash.c
lib /OUT:$(MTLZ4Lib) ../lz4/lib/lz4mt.obj ../lz4/lib/lz4framemt.obj ../lz4/lib/lz4hcmt.obj ../lz4/lib/xxhashmt.obj
clean:
-del /f $(cobj) main.obj $(KernelExp)
-del /f mtscheme.exe
-del /f mdscheme.exe

154
c/Makefile.ta6nt Normal file
View file

@ -0,0 +1,154 @@
# Makefile.ta6nt
# 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 = ta6nt
# following have to use \ for directory separator
SchemeInclude = ..\boot\$m
KernelDll = ..\bin\$m\csv959.dll
KernelLib = ..\bin\$m\csv959.lib
MTKernelLib = ..\boot\$m\csv959mt.lib
MDKernelLib = ..\boot\$m\csv959md.lib
KernelExp = ..\bin\$m\csv959.exp
Exec = ..\bin\$m\scheme.exe
MTMain = ..\boot\$m\mainmt.obj
MDMain = ..\boot\$m\mainmd.obj
ResFile = ..\boot\$m\scheme.res
# We use MD so that we can link with and load DLLs built against msvcrxxx.dll
CFLAGS=/nologo /Ox /W3 /Zi /I$(SchemeInclude) /I..\zlib /I..\lz4\lib /DX86_64 /DWIN32 /D_CRT_SECURE_NO_WARNINGS
MDCFLAGS=$(CFLAGS) /MD
MTCFLAGS=$(CFLAGS) /MT
DLLLDFLAGS=/debug:full /machine:X64 /nologo
# stack limit is 1MB by default. this is not enough for one of the mats in foreign.ms, which
# builds up nested C & Scheme stack frames. 2MB seems to be enough, but we set to 16MB.
EXELDFLAGS=/debug:full /machine:X64 /incremental:no /nologo /STACK:0x1000000
# use following flags for debugging
# CFLAGS=/nologo /Od /W3 /Zi /I$(SchemeInclude) /I..\zlib /I..\lz4\lib /DX86_64 /DWIN32 /D_CRT_SECURE_NO_WARNINGS
# MDCFLAGS=$(CFLAGS) /MDd
# MTCFLAGS=$(CFLAGS) /MTd
SystemLib=rpcrt4.lib ole32.lib advapi32.lib User32.lib
MDZlibLib=..\zlib\zlib.lib
MTZlibLib=..\zlib\zlibmt.lib
MDLZ4Lib=..\lz4\lib\liblz4.lib
MTLZ4Lib=..\lz4\lib\liblz4mt.lib
csrc=statics.c segment.c alloc.c symbol.c intern.c gcwrapper.c gc-011.c gc-oce.c gc-ocd.c\
number.c schsig.c io.c new-io.c print.c fasl.c stats.c\
foreign.c prim.c prim5.c flushcache.c\
windows.c\
schlib.c thread.c expeditor.c scheme.c compress-io.c
cobj=statics.obj segment.obj alloc.obj symbol.obj intern.obj gcwrapper.obj gc-011.obj gc-oce.obj gc-ocd.obj\
number.obj schsig.obj io.obj new-io.obj print.obj fasl.obj stats.obj\
foreign.obj prim.obj prim5.obj flushcache.obj\
windows.obj\
schlib.obj thread.obj expeditor.obj scheme.obj compress-io.obj
hsrc=system.h types.h version.h globals.h externs.h compress-io.h segment.h gc.c thread.h sort.h itest.c
.SUFFIXES:
all: $(Exec) $(MTKernelLib) $(MDKernelLib) $(MTMain)
$(KernelLib) $(MTKernelLib) $(MDKernelLib): $(hsrc)
$(KernelLib) $(MTKernelLib) $(MDKernelLib): $(SchemeInclude)/equates.h $(SchemeInclude)/scheme.h
$(KernelLib) $(MTKernelLib) $(MDKernelLib): ..\zlib/zconf.h ..\zlib/zlib.h
$(KernelLib) $(MTKernelLib) $(MDKernelLib): ../lz4/lib/lz4.h ../lz4/lib/lz4frame.h
$(MTKernelLib): $(csrc) $(MTZlibLib) $(MTLZ4Lib) a6nt-jump.obj
-del /f $(MTKernelLib)
cl /DSCHEME_STATIC /c $(MTCFLAGS) $(csrc)
link /lib /nologo -out:$(MTKernelLib) $(cobj) $(MTZlibLib) $(MTLZ4Lib) a6nt-jump.obj
$(MDKernelLib): $(csrc) $(MDZlibLib) $(MDLZ4Lib) a6nt-jump.obj
-del /f $(MDKernelLib)
cl /DSCHEME_STATIC /c $(MDCFLAGS) $(csrc)
link /lib /nologo -out:$(MDKernelLib) $(cobj) $(MDZlibLib) $(MDLZ4Lib) a6nt-jump.obj
# nmake builds Dll twice if we list it with $(KernelLib) below
$(KernelDll): $(KernelLib)
# base chosen to be consistent with "microsoft conventions"
# http://www.windevnet.com/documents/s=7482/win1078945937961/
# but set at a basically odd address to reduce likelihood of
# conflicts with other dlls. use 'depends <exefile>' to check.
# we no longer attempt to rebase other the CRT dll since it
# has already been signed.
$(KernelLib): $(ResFile) $(csrc) $(MDZlibLib) $(MDLZ4Lib) a6nt-jump.obj
-del /f $(KernelLib)
-del /f $(KernelDll)
cl /c $(MDCFLAGS) $(csrc)
link -dll -out:$(KernelDll) $(DLLLDFLAGS) $(ResFile) $(cobj) $(MDZlibLib) $(MDLZ4Lib) $(SystemLib) a6nt-jump.obj
editbin /nologo /rebase:base=0x67480000 $(KernelDll)
$(MTMain): main.c
-del /f $(MTMain)
cl /DSCHEME_STATIC /c $(MTCFLAGS) main.c
copy main.obj $(MTMain)
$(MDMain): main.c
-del /f $(MDMain)
cl /c $(MDCFLAGS) main.c
copy main.obj $(MDMain)
$(Exec): $(ResFile) $(MDMain) $(KernelLib)
-del /f $(Exec)
link /out:$(Exec) $(EXELDFLAGS) $(ResFile) $(MDMain) $(KernelLib)
mt -manifest ..\..\c\scheme.exe.manifest -outputresource:$(Exec);1
$(ResFile): scheme.rc
-del /f $(ResFile)
rc -r /fo $(ResFile) -DWIN32 scheme.rc
# for testing mt kernel and mainmt.obj:
mtscheme.exe: $(ResFile) $(MTMain) $(MTKernelLib)
-del /f mtscheme.exe
link /out:mtscheme.exe $(EXELDFLAGS) $(ResFile) $(MTMain) $(MTKernelLib) $(SystemLib)
# for testing md kernel and mainmd.obj:
mdscheme.exe: $(ResFile) $(MDMain) $(MDKernelLib)
-del /f mdscheme.exe
link /out:mdscheme.exe $(EXELDFLAGS) $(ResFile) $(MDMain) $(MDKernelLib) $(SystemLib)
..\zlib\zlib.h ..\zlib\zconf.h $(MDZlibLib) $(MTZlibLib):
cd ../zlib
nmake /nologo -f win32/Makefile.msc AR="link /lib" CFLAGS="-nologo -MT -O2 $(LOC)"
ren zlib.lib zlibmt.lib
nmake /nologo -f win32/Makefile.msc clean
nmake /nologo -f win32/Makefile.msc AR="link /lib"
cd ../c
$(MDLZ4Lib) $(MTLZ4Lib): ../lz4/lib/lz4.c ../lz4/lib/lz4frame.c ../lz4/lib/lz4hc.c
cl /c /Fo../lz4/lib/lz4.obj $(MDCFLAGS) ../lz4/lib/lz4.c
cl /c /Fo../lz4/lib/lz4frame.obj $(MDCFLAGS) ../lz4/lib/lz4frame.c
cl /c /Fo../lz4/lib/lz4hc.obj $(MDCFLAGS) ../lz4/lib/lz4hc.c
cl /c /Fo../lz4/lib/xxhash.obj $(MDCFLAGS) ../lz4/lib/xxhash.c
lib /OUT:$(MDLZ4Lib) ../lz4/lib/lz4.obj ../lz4/lib/lz4frame.obj ../lz4/lib/lz4hc.obj ../lz4/lib/xxhash.obj
cl /c /Fo../lz4/lib/lz4mt.obj $(MTCFLAGS) ../lz4/lib/lz4.c
cl /c /Fo../lz4/lib/lz4framemt.obj $(MTCFLAGS) ../lz4/lib/lz4frame.c
cl /c /Fo../lz4/lib/lz4hcmt.obj $(MTCFLAGS) ../lz4/lib/lz4hc.c
cl /c /Fo../lz4/lib/xxhashmt.obj $(MTCFLAGS) ../lz4/lib/xxhash.c
lib /OUT:$(MTLZ4Lib) ../lz4/lib/lz4mt.obj ../lz4/lib/lz4framemt.obj ../lz4/lib/lz4hcmt.obj ../lz4/lib/xxhashmt.obj
a6nt-jump.obj: a6nt-jump.asm
ml64 /nologo /W3 /Zi /c a6nt-jump.asm
clean:
-del /f $(cobj) main.obj $(KernelExp) a6nt-jump.obj
-del /f mtscheme.exe
-del /f mdscheme.exe

150
c/Makefile.ti3nt Normal file
View file

@ -0,0 +1,150 @@
# Makefile.ti3nt
# 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 = ti3nt
# following have to use \ for directory separator
SchemeInclude = ..\boot\$m
KernelDll = ..\bin\$m\csv959.dll
KernelLib = ..\bin\$m\csv959.lib
MTKernelLib = ..\boot\$m\csv959mt.lib
MDKernelLib = ..\boot\$m\csv959md.lib
KernelExp = ..\bin\$m\csv959.exp
Exec = ..\bin\$m\scheme.exe
MTMain = ..\boot\$m\mainmt.obj
MDMain = ..\boot\$m\mainmd.obj
ResFile = ..\boot\$m\scheme.res
# We use MD so that we can link with and load DLLs built against msvcrxxx.dll
CFLAGS=/nologo /fp:precise /Ox /W3 /Zi /I$(SchemeInclude) /I..\zlib /I..\lz4\lib /DI386 /DWIN32 /D_CRT_SECURE_NO_WARNINGS
MDCFLAGS=$(CFLAGS) /MD
MTCFLAGS=$(CFLAGS) /MT
DLLLDFLAGS=/debug:full /machine:ix86 /nologo
# see note in Makefile.a6nt regarding stack size. we use 8MB here to be consistent.
EXELDFLAGS=/debug:full /machine:ix86 /incremental:no /nologo /STACK:0x800000
# use following flags for debugging
# CFLAGS=/nologo /fp:precise /Od /W3 /Zi /I$(SchemeInclude) /I..\zlib /I..\lz4\lib /DI386 /DWIN32 /D_CRT_SECURE_NO_WARNINGS
# MDCFLAGS=$(CFLAGS) /MDd
# MTCFLAGS=$(CFLAGS) /MTd
SystemLib=rpcrt4.lib ole32.lib advapi32.lib User32.lib
MDZlibLib=..\zlib\zlib.lib
MTZlibLib=..\zlib\zlibmt.lib
MDLZ4Lib=..\lz4\lib\liblz4.lib
MTLZ4Lib=..\lz4\lib\liblz4mt.lib
csrc=statics.c segment.c alloc.c symbol.c intern.c gcwrapper.c gc-011.c gc-oce.c gc-ocd.c\
number.c schsig.c io.c new-io.c print.c fasl.c stats.c\
foreign.c prim.c prim5.c flushcache.c\
windows.c\
schlib.c thread.c expeditor.c scheme.c compress-io.c
cobj=statics.obj segment.obj alloc.obj symbol.obj intern.obj gcwrapper.obj gc-011.obj gc-oce.obj gc-ocd.obj\
number.obj schsig.obj io.obj new-io.obj print.obj fasl.obj stats.obj\
foreign.obj prim.obj prim5.obj flushcache.obj\
windows.obj\
schlib.obj thread.obj expeditor.obj scheme.obj compress-io.obj
hsrc=system.h types.h version.h globals.h externs.h compress-io.h segment.h gc.c thread.h sort.h itest.c
.SUFFIXES:
all: $(Exec) $(MTKernelLib) $(MDKernelLib) $(MTMain)
$(KernelLib) $(MTKernelLib) $(MDKernelLib): $(hsrc)
$(KernelLib) $(MTKernelLib) $(MDKernelLib): $(SchemeInclude)/equates.h $(SchemeInclude)/scheme.h
$(KernelLib) $(MTKernelLib) $(MDKernelLib): ..\zlib/zconf.h ..\zlib/zlib.h
$(KernelLib) $(MTKernelLib) $(MDKernelLib): ../lz4/lib/lz4.h ../lz4/lib/lz4frame.h
$(MTKernelLib): $(csrc) $(MTZlibLib) $(MTLZ4Lib)
-del /f $(MTKernelLib)
cl /DSCHEME_STATIC /c $(MTCFLAGS) $(csrc)
link /lib /nologo -out:$(MTKernelLib) $(cobj) $(MTZlibLib) $(MTLZ4Lib)
$(MDKernelLib): $(csrc) $(MDZlibLib) $(MDLZ4Lib)
-del /f $(MDKernelLib)
cl /DSCHEME_STATIC /c $(MDCFLAGS) $(csrc)
link /lib /nologo -out:$(MDKernelLib) $(cobj) $(MDZlibLib) $(MDLZ4Lib)
# nmake builds Dll twice if we list it with $(KernelLib) below
$(KernelDll): $(KernelLib)
# base chosen to be consistent with "microsoft conventions"
# http://www.windevnet.com/documents/s=7482/win1078945937961/
# but set at a basically odd address to reduce likelihood of
# conflicts with other dlls. use 'depends <exefile>' to check.
# we no longer attempt to rebase other the CRT dll since it
# has already been signed.
$(KernelLib): $(ResFile) $(csrc) $(MDZlibLib) $(MDLZ4Lib)
-del /f $(KernelLib)
-del /f $(KernelDll)
cl /c $(MDCFLAGS) $(csrc)
link -dll -out:$(KernelDll) $(DLLLDFLAGS) $(ResFile) $(cobj) $(MDZlibLib) $(MDLZ4Lib) $(SystemLib)
editbin /nologo /rebase:base=0x67480000 $(KernelDll)
$(MTMain): main.c
-del /f $(MTMain)
cl /DSCHEME_STATIC /c $(MTCFLAGS) main.c
copy main.obj $(MTMain)
$(MDMain): main.c
-del /f $(MDMain)
cl /c $(MDCFLAGS) main.c
copy main.obj $(MDMain)
$(Exec): $(ResFile) $(MDMain) $(KernelLib)
-del /f $(Exec)
link /out:$(Exec) $(EXELDFLAGS) $(ResFile) $(MDMain) $(KernelLib)
mt -manifest ..\..\c\scheme.exe.manifest -outputresource:$(Exec);1
$(ResFile): scheme.rc
-del /f $(ResFile)
rc -r /fo $(ResFile) -DWIN32 scheme.rc
# for testing mt kernel and mainmt.obj:
mtscheme.exe: $(ResFile) $(MTMain) $(MTKernelLib)
-del /f mtscheme.exe
link /out:mtscheme.exe $(EXELDFLAGS) $(ResFile) $(MTMain) $(MTKernelLib) $(SystemLib)
# for testing md kernel and mainmd.obj:
mdscheme.exe: $(ResFile) $(MDMain) $(MDKernelLib)
-del /f mdscheme.exe
link /out:mdscheme.exe $(EXELDFLAGS) $(ResFile) $(MDMain) $(MDKernelLib) $(SystemLib)
..\zlib\zlib.h ..\zlib\zconf.h $(MDZlibLib) $(MTZlibLib):
cd ../zlib
nmake /nologo -f win32/Makefile.msc AR="link /lib" CFLAGS="-nologo -MT -O2 $(LOC)"
ren zlib.lib zlibmt.lib
nmake /nologo -f win32/Makefile.msc clean
nmake /nologo -f win32/Makefile.msc AR="link /lib"
cd ../c
$(MDLZ4Lib) $(MTLZ4Lib): ../lz4/lib/lz4.c ../lz4/lib/lz4frame.c ../lz4/lib/lz4hc.c
cl /c /Fo../lz4/lib/lz4.obj $(MDCFLAGS) ../lz4/lib/lz4.c
cl /c /Fo../lz4/lib/lz4frame.obj $(MDCFLAGS) ../lz4/lib/lz4frame.c
cl /c /Fo../lz4/lib/lz4hc.obj $(MDCFLAGS) ../lz4/lib/lz4hc.c
cl /c /Fo../lz4/lib/xxhash.obj $(MDCFLAGS) ../lz4/lib/xxhash.c
lib /OUT:$(MDLZ4Lib) ../lz4/lib/lz4.obj ../lz4/lib/lz4frame.obj ../lz4/lib/lz4hc.obj ../lz4/lib/xxhash.obj
cl /c /Fo../lz4/lib/lz4mt.obj $(MTCFLAGS) ../lz4/lib/lz4.c
cl /c /Fo../lz4/lib/lz4framemt.obj $(MTCFLAGS) ../lz4/lib/lz4frame.c
cl /c /Fo../lz4/lib/lz4hcmt.obj $(MTCFLAGS) ../lz4/lib/lz4hc.c
cl /c /Fo../lz4/lib/xxhashmt.obj $(MTCFLAGS) ../lz4/lib/xxhash.c
lib /OUT:$(MTLZ4Lib) ../lz4/lib/lz4mt.obj ../lz4/lib/lz4framemt.obj ../lz4/lib/lz4hcmt.obj ../lz4/lib/xxhashmt.obj
clean:
-del /f $(cobj) main.obj $(KernelExp)
-del /f mtscheme.exe
-del /f mdscheme.exe

47
c/Mf-a6fb Normal file
View file

@ -0,0 +1,47 @@
# Mf-a6fb
# 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 = a6fb
Cpu = X86_64
mdinclude = -I/usr/local/include -I/usr/X11R6/include
mdclib = -L/usr/local/lib -liconv -lm ${ncursesLib} -lossp-uuid
C = ${CC} ${CPPFLAGS} -Wpointer-arith -Wextra -Werror -O ${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 -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)

46
c/Mf-a6le Normal file
View file

@ -0,0 +1,46 @@
# Mf-a6le
# 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 = a6le
Cpu = X86_64
mdclib = -lm -ldl ${ncursesLib} -lrt -luuid
C = ${CC} ${CPPFLAGS} -m64 -msse2 -Wpointer-arith -Wall -Wextra -Werror -Wno-implicit-fallthrough -O2 ${CFLAGS}
o = o
mdsrc = i3le.c
mdobj = i3le.o
.SUFFIXES:
.SUFFIXES: .c .o
.c.o:
$C -c -D${Cpu} -I${Include} ${zlibInc} ${LZ4Inc} $*.c
include Mf-base
${KernelO}: ${kernelobj} ${zlibDep} ${LZ4Dep}
${LD} -melf_x86_64 -r -X -o ${KernelO} ${kernelobj} ${zlibLib} ${LZ4Lib}
${KernelLib}: ${kernelobj}
${AR} ${ARFLAGS} ${KernelLib} ${kernelobj}
${Scheme}: ${Kernel} ${KernelLinkDeps} ${Main}
$C -rdynamic -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS}
../zlib/configure.log:
(cd ../zlib; CFLAGS="${CFLAGS} -m64 -fPIC" ./configure --64)
../lz4/lib/liblz4.a: ${LZ4Sources}
(cd ../lz4/lib; CFLAGS="${CFLAGS} -m64" ${MAKE} liblz4.a)

48
c/Mf-a6nb Normal file
View file

@ -0,0 +1,48 @@
# Mf-a6nb
# 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 = a6nb
Cpu = X86_64
mdinclude = -I/usr/X11R7/include -I/usr/pkg/include -I/usr/pkg/include/ncurses -I/usr/local/include -I/usr/X11R6/include
mdclib = /usr/lib/i18n/libiconv_std.a -lm /usr/pkg/lib/libncurses.a
C = ${CC} ${CPPFLAGS} -m64 -Wpointer-arith -Wextra -Werror -O ${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 -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS}
paxctl +m ${Scheme}
../zlib/configure.log:
(cd ../zlib; CFLAGS="${CFLAGS} -m64" ./configure --64)
../lz4/lib/liblz4.a: ${LZ4Sources}
(cd ../lz4/lib; CFLAGS="${CFLAGS} -m64" ${MAKE} liblz4.a)

65
c/Mf-a6nt Normal file
View file

@ -0,0 +1,65 @@
# Mf-a6nt
# 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 = a6nt
Cpu = X86_64
clib=
o = obj
mdobj=windows.$o
mdsrc=a6nt-jump.asm windows.c Makefile.$m cs.ico scheme.rc make.bat
mdclean=vs.bat make.bat scheme.res ../bin/$m/*.exp mtscheme.exe* mdscheme.exe*
cross=f
include Mf-base
export MSYS_NO_PATHCONV=1
export MSYS2_ARG_CONV_EXCL=*
${Scheme}${cross:f=}: make.bat
cmd.exe /c make.bat
cp ../bin/$m/scheme.exe ../bin/$m/petite.exe
cp ../bin/$m/scheme.pdb ../bin/$m/petite.pdb
make.bat: vs.bat
echo '@echo off' > $@
echo 'set MAKEFLAGS=' >> $@
echo 'vs.bat amd64 && nmake /f Makefile.$m /nologo %*' >> $@
chmod +x $@
# -------------------------------------------------------
# For cross-compilation, triggered by setting cross=t o=o
C = ${CC} ${CPPFLAGS} -O2 ${CFLAGS}
${Scheme}${cross:t=}: ${Main} ${Kernel} ${KernelLinkDeps}
$C -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS} -lshell32 -luser32 -lole32 -lrpcrt4 -luuid
.c.$o:
$C -c -D${Cpu} -I${Include} ${zlibInc} ${LZ4Inc} $*.c
${KernelLib}: ${kernelobj}
${AR} ${ARFLAGS} ${KernelLib} ${kernelobj}
${KernelO}: ${kernelobj} ${zlibDep} ${LZ4Dep}
${LD} -r -X -o ${KernelO} ${kernelobj} ${zlibLib} ${LZ4Lib}
../zlib/configure.log:
echo "all:" >> ../zlib/Makefile
echo ' $$(MAKE) -f win32/Makefile.gcc CC="$(CC)" CFLAGS="$(CFLAGS)" AR="$(AR)" RANLIB="$(RANLIB)" RC="$(WINDRES)"' >> ../zlib/Makefile
touch ../zlib/configure.log
../lz4/lib/liblz4.a: ${LZ4Sources}
(cd ../lz4/lib; CC="$(CC)" CFLAGS="$(CFLAGS)" AR="$(AR)" RANLIB="$(RANLIB)" ${MAKE} liblz4.a)

47
c/Mf-a6ob Normal file
View file

@ -0,0 +1,47 @@
# Mf-a6ob
# 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 = a6ob
Cpu = X86_64
mdinclude = -I/usr/local/include -I/usr/X11R6/include
mdclib = -L/usr/local/lib -liconv -lm ${ncursesLib} -lossp-uuid
C = ${CC} ${CPPFLAGS} -Wpointer-arith -Werror -O ${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)

46
c/Mf-a6osx Normal file
View file

@ -0,0 +1,46 @@
# Mf-a6osx
# 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 = a6osx
Cpu = X86_64
mdclib = -liconv -lm ${ncursesLib}
C = ${CC} ${CPPFLAGS} -m64 -Wpointer-arith -Wall -Wextra -Wno-implicit-fallthrough -Werror -O2 -I/opt/X11/include/ ${CFLAGS}
o = o
mdsrc = i3le.c
mdobj = i3le.o
.SUFFIXES:
.SUFFIXES: .c .o
.c.o:
$C -c -D${Cpu} -I${Include} ${zlibInc} ${LZ4Inc} $*.c
include Mf-base
${KernelO}: ${kernelobj} ${zlibDep} ${LZ4Dep}
${LD} -r -o ${KernelO} ${kernelobj} ${zlibLib} ${LZ4Lib}
${KernelLib}: ${kernelobj}
${AR} ${ARFLAGS} ${KernelLib} ${kernelobj}
${Scheme}: ${Kernel} ${KernelLinkDeps} ${Main}
$C -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)

46
c/Mf-a6s2 Normal file
View file

@ -0,0 +1,46 @@
# Mf-a6s2
# 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 = a6s2
Cpu = X86_64
mdclib = -lnsl -ldl -lm ${cursesLib} -lrt
C = ${CC} ${CPPFLAGS} -m64 -Wpointer-arith -Wextra -Werror -O ${CFLAGS}
o = o
mdsrc = i3le.c
mdobj = i3le.o
.SUFFIXES:
.SUFFIXES: .c .o
.c.o:
$C -c -DSOLARIS -D${Cpu} -I${Include} ${zlibInc} ${LZ4Inc} $*.c
include Mf-base
${KernelO}: ${kernelobj} ${zlibDep} ${LZ4Dep}
${LD} -melf_x86_64 -r -X -o ${KernelO} ${kernelobj} ${zlibLib} ${LZ4Lib}
${KernelLib}: ${kernelobj}
${AR} ${ARFLAGS} ${KernelLib} ${kernelobj}
${Scheme}: ${Kernel} ${KernelLinkDeps} ${Main}
$C -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)

46
c/Mf-arm32le Normal file
View file

@ -0,0 +1,46 @@
# Mf-arm32le
# 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 = arm32le
Cpu = ARMV6
mdclib = -lm -ldl ${ncursesLib} -lrt -luuid
C = ${CC} ${CPPFLAGS} -Wpointer-arith -Wextra -Werror -Wno-implicit-fallthrough -O2 ${CFLAGS}
o = o
mdsrc = arm32le.c
mdobj = arm32le.o
.SUFFIXES:
.SUFFIXES: .c .o
.c.o:
$C -c -D${Cpu} -I${Include} ${zlibInc} ${LZ4Inc} $*.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 -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS}
../zlib/configure.log:
(cd ../zlib; CFLAGS="${CFLAGS} -fPIC" ./configure)
../lz4/lib/liblz4.a: ${LZ4Sources}
(cd ../lz4/lib; ${MAKE} liblz4.a)

82
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

47
c/Mf-i3fb Normal file
View file

@ -0,0 +1,47 @@
# Mf-i3fb
# 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 = i3fb
Cpu = I386
mdinclude = -I/usr/local/include -I/usr/X11R6/include
mdclib = -L/usr/local/lib -liconv -lm ${ncursesLib} -lossp-uuid
C = ${CC} ${CPPFLAGS} -Wpointer-arith -Wextra -Werror -O ${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 -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS}
../zlib/configure.log:
(cd ../zlib; CFLAGS="${CFLAGS} -m32" ./configure)
../lz4/lib/liblz4.a: ${LZ4Sources}
(cd ../lz4/lib; CFLAGS="${CFLAGS} -m32" ${MAKE} liblz4.a)

46
c/Mf-i3le Normal file
View file

@ -0,0 +1,46 @@
# Mf-i3le
# 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 = i3le
Cpu = I386
mdclib = -lm -ldl ${ncursesLib} -lrt -luuid
C = ${CC} ${CPPFLAGS} -m32 -msse2 -Wpointer-arith -Wall -Wextra -Werror -Wno-implicit-fallthrough -O2 -fno-stack-protector ${CFLAGS}
o = o
mdsrc = i3le.c
mdobj = i3le.o
.SUFFIXES:
.SUFFIXES: .c .o
.c.o:
$C -c -D${Cpu} -I${Include} ${zlibInc} ${LZ4Inc} $*.c
include Mf-base
${KernelO}: ${kernelobj} ${zlibDep} ${LZ4Dep}
${LD} -melf_i386 -r -X -o ${KernelO} ${kernelobj} ${zlibLib} ${LZ4Lib}
${KernelLib}: ${kernelobj}
${AR} ${ARFLAGS} ${KernelLib} ${kernelobj}
${Scheme}: ${Kernel} ${KernelLinkDeps} ${Main}
$C -rdynamic -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS}
../zlib/configure.log:
(cd ../zlib; CFLAGS="${CFLAGS} -m32 -fPIC" ./configure)
../lz4/lib/liblz4.a: ${LZ4Sources}
(cd ../lz4/lib; CFLAGS="${CFLAGS} -m32" ${MAKE} liblz4.a)

48
c/Mf-i3nb Normal file
View file

@ -0,0 +1,48 @@
# Mf-i3nb
# 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 = i3nb
Cpu = I386
mdinclude = -I/usr/X11R7/include -I/usr/pkg/include -I/usr/pkg/include/ncurses -I/usr/X11R6/include
mdclib = /usr/lib/i18n/libiconv_std.a -lm /usr/pkg/lib/libncurses.a
C = ${CC} ${CPPFLAGS} -Wpointer-arith -Wextra -Werror -O ${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 -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS}
paxctl +m ${Scheme}
../zlib/configure.log:
(cd ../zlib; CFLAGS="${CFLAGS} -m32" ./configure)
../lz4/lib/liblz4.a: ${LZ4Sources}
(cd ../lz4/lib; CFLAGS="${CFLAGS} -m32" ${MAKE} liblz4.a)

65
c/Mf-i3nt Normal file
View file

@ -0,0 +1,65 @@
# Mf-i3nt
# 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 = i3nt
Cpu = I386
clib=
o = obj
mdobj=windows.$o
mdsrc=windows.c Makefile.$m cs.ico scheme.rc make.bat
mdclean=vs.bat make.bat scheme.res ../bin/$m/*.exp mtscheme.exe* mdscheme.exe*
cross=f
include Mf-base
export MSYS_NO_PATHCONV=1
export MSYS2_ARG_CONV_EXCL=*
${Scheme}${cross:f=}: make.bat
cmd.exe /c make.bat
cp ../bin/$m/scheme.exe ../bin/$m/petite.exe
cp ../bin/$m/scheme.pdb ../bin/$m/petite.pdb
make.bat: vs.bat
echo '@echo off' > $@
echo 'set MAKEFLAGS=' >> $@
echo 'vs.bat x86 && nmake /f Makefile.$m /nologo %*' >> $@
chmod +x $@
# -------------------------------------------------------
# For cross-compilation, triggered by setting cross=t o=o
C = ${CC} ${CPPFLAGS} -O2 ${CFLAGS}
${Scheme}${cross:t=}: ${Main} ${Kernel} ${KernelLinkDeps}
$C -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS} -lshell32 -luser32 -lole32 -lrpcrt4 -luuid
.c.$o:
$C -c -D${Cpu} -I${Include} ${zlibInc} ${LZ4Inc} $*.c
${KernelLib}: ${kernelobj}
${AR} ${ARFLAGS} ${KernelLib} ${kernelobj}
${KernelO}: ${kernelobj} ${zlibDep} ${LZ4Dep}
${LD} -r -X -o ${KernelO} ${kernelobj} ${zlibLib} ${LZ4Lib}
../zlib/configure.log:
echo "all:" >> ../zlib/Makefile
echo ' $$(MAKE) -f win32/Makefile.gcc CC="$(CC)" CFLAGS="$(CFLAGS)" AR="$(AR)" RANLIB="$(RANLIB)" RC="$(WINDRES)"' >> ../zlib/Makefile
touch ../zlib/configure.log
../lz4/lib/liblz4.a: ${LZ4Sources}
(cd ../lz4/lib; CC="$(CC)" CFLAGS="$(CFLAGS)" AR="$(AR)" RANLIB="$(RANLIB)" ${MAKE} liblz4.a)

47
c/Mf-i3ob Normal file
View file

@ -0,0 +1,47 @@
# Mf-i3ob
# 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 = i3ob
Cpu = I386
mdinclude = -I/usr/local/include -I/usr/X11R6/include
mdclib = -L/usr/local/lib -liconv -lm ${ncursesLib} -lossp-uuid
C = ${CC} ${CPPFLAGS} -Wpointer-arith -Werror -O ${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} -m32" ./configure)
../lz4/lib/liblz4.a: ${LZ4Sources}
(cd ../lz4/lib; CFLAGS="${CFLAGS} -m32" ${MAKE} liblz4.a)

46
c/Mf-i3osx Normal file
View file

@ -0,0 +1,46 @@
# Mf-i3osx
# 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 = i3osx
Cpu = I386
mdclib = -liconv -lm ${ncursesLib}
C = ${CC} ${CPPFLAGS} -m32 -Wpointer-arith -Wall -Wextra -Wno-implicit-fallthrough -Werror -O2 -msse2 -I/opt/X11/include/ ${CFLAGS}
o = o
mdsrc = i3le.c
mdobj = i3le.o
.SUFFIXES:
.SUFFIXES: .c .o
.c.o:
$C -c -D${Cpu} -I${Include} ${zlibInc} ${LZ4Inc} $*.c
include Mf-base
${KernelO}: ${kernelobj} ${zlibDep} ${LZ4Dep}
${LD} -r -o ${KernelO} ${kernelobj} ${zlibLib} ${LZ4Lib}
${KernelLib}: ${kernelobj}
${AR} ${ARFLAGS} ${KernelLib} ${kernelobj}
${Scheme}: ${Kernel} ${KernelLinkDeps} ${Main}
$C -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS}
../zlib/configure.log:
(cd ../zlib; CFLAGS="${CFLAGS} -m32" ./configure)
../lz4/lib/liblz4.a: ${LZ4Sources}
(cd ../lz4/lib; CFLAGS="${CFLAGS} -m32" ${MAKE} liblz4.a)

47
c/Mf-i3qnx Normal file
View file

@ -0,0 +1,47 @@
# Mf-i3qnx
# 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 = i3qnx
Cpu = I386
mdclib = -lm /usr/local/lib/libiconv.so -lsocket ${ncursesLib}
C = qcc ${CPPFLAGS} -m32 -Wpointer-arith -Wextra -Werror -O2 -N2048K ${CFLAGS}
o = o
mdsrc = i3le.c
mdobj = i3le.o
LocalInclude = /usr/local/include
.SUFFIXES:
.SUFFIXES: .c .o
.c.o:
$C -c -D${Cpu} -I${Include} ${zlibInc} ${LZ4Inc} -I${LocalInclude} $*.c
include Mf-base
${KernelO}: ${kernelobj} ${zlibDep} ${LZ4Dep}
${LD} -mi386nto -r -X -o ${KernelO} ${kernelobj} ${zlibLib} ${LZ4Lib}
${KernelLib}: ${kernelobj}
${AR} ${ARFLAGS} ${KernelLib} ${kernelobj}
${Scheme}: ${Kernel} ${KernelLinkDeps} ${Main}
$C -Wl,--export-dynamic -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS}
../zlib/configure.log:
(cd ../zlib; CFLAGS="${CFLAGS} -m32" ./configure)
../lz4/lib/liblz4.a: ${LZ4Sources}
(cd ../lz4/lib; CFLAGS="${CFLAGS} -m32" ${MAKE} liblz4.a)

46
c/Mf-i3s2 Normal file
View file

@ -0,0 +1,46 @@
# Mf-i3s2
# 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 = i3s2
Cpu = I386
mdclib = -lnsl -ldl -lm ${cursesLib} -lrt
C = ${CC} ${CFLAGS} -m32 -Wpointer-arith -Wextra -Werror -O ${CPPFLAGS}
o = o
mdsrc = i3le.c
mdobj = i3le.o
.SUFFIXES:
.SUFFIXES: .c .o
.c.o:
$C -c -DSOLARIS -D${Cpu} -I${Include} ${zlibInc} ${LZ4Inc} $*.c
include Mf-base
${KernelO}: ${kernelobj} ${zlibDep} ${LZ4Dep}
${LD} -melf_i386 -r -X -o ${KernelO} ${kernelobj} ${zlibLib} ${LZ4Lib}
${KernelLib}: ${kernelobj}
${AR} ${ARFLAGS} ${KernelLib} ${kernelobj}
${Scheme}: ${Kernel} ${KernelLinkDeps} ${Main}
$C -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS}
../zlib/configure.log:
(cd ../zlib; CFLAGS="${CFLAGS} -m32" ./configure)
../lz4/lib/liblz4.a: ${LZ4Sources}
(cd ../lz4/lib; CFLAGS="${CFLAGS} -m32" ${MAKE} liblz4.a)

46
c/Mf-ppc32le Normal file
View file

@ -0,0 +1,46 @@
# Mf-ppc32le
# 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 = ppc32le
Cpu = PPC32
mdclib = -lm -ldl ${ncursesLib} -lrt -luuid
C = ${CC} ${CPPFLAGS} -m32 -Wpointer-arith -Wextra -Werror -Wno-implicit-fallthrough -O2 ${CFLAGS}
o = o
mdsrc = ppc32.c
mdobj = ppc32.o
.SUFFIXES:
.SUFFIXES: .c .o
.c.o:
$C -c -D${Cpu} -I${Include} ${zlibInc} ${LZ4Inc} $*.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 -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS}
../zlib/configure.log:
(cd ../zlib; CFLAGS="${CFLAGS} -m32 -fPIC" ./configure)
../lz4/lib/liblz4.a: ${LZ4Sources}
(cd ../lz4/lib; CFLAGS="${CFLAGS} -m32" ${MAKE} liblz4.a)

47
c/Mf-ta6fb Normal file
View file

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

46
c/Mf-ta6le Normal file
View file

@ -0,0 +1,46 @@
# Mf-ta6le
# 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 = ta6le
Cpu = X86_64
mdclib = -lm -ldl ${ncursesLib} -lpthread -lrt -luuid
C = ${CC} ${CPPFLAGS} -m64 -msse2 -Wpointer-arith -Wall -Wextra -Werror -Wno-implicit-fallthrough -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} $*.c
include Mf-base
${KernelO}: ${kernelobj} ${zlibDep} ${LZ4Dep}
${LD} -melf_x86_64 -r -X -o ${KernelO} ${kernelobj} ${zlibLib} ${LZ4Lib}
${KernelLib}: ${kernelobj}
${AR} ${ARFLAGS} ${KernelLib} ${kernelobj}
${Scheme}: ${Kernel} ${KernelLinkDeps} ${Main}
$C -rdynamic -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS}
../zlib/configure.log:
(cd ../zlib; CFLAGS="${CFLAGS} -m64 -fPIC" ./configure --64)
../lz4/lib/liblz4.a: ${LZ4Sources}
(cd ../lz4/lib; CFLAGS="${CFLAGS} -m64" ${MAKE} liblz4.a)

48
c/Mf-ta6nb Normal file
View file

@ -0,0 +1,48 @@
# Mf-ta6nb
# 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 = ta6nb
Cpu = X86_64
mdinclude = -I/usr/X11R7/include -I/usr/pkg/include -I/usr/pkg/include/ncurses -I/usr/X11R6/include
mdclib = /usr/lib/i18n/libiconv_std.a -lm /usr/pkg/lib/libncurses.a -lpthread
C = ${CC} ${CPPFLAGS} -m64 -Wpointer-arith -Wextra -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 -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS}
paxctl +m ${Scheme}
../zlib/configure.log:
(cd ../zlib; CFLAGS="${CFLAGS} -m64" ./configure --64)
../lz4/lib/liblz4.a: ${LZ4Sources}
(cd ../lz4/lib; CFLAGS="${CFLAGS} -m64" ${MAKE} liblz4.a)

65
c/Mf-ta6nt Normal file
View file

@ -0,0 +1,65 @@
# Mf-ta6nt
# 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 = ta6nt
Cpu = X86_64
clib=
o = obj
mdobj=windows.$o
mdsrc=a6nt-jump.asm windows.c Makefile.$m cs.ico scheme.rc make.bat
mdclean=vs.bat make.bat scheme.res ../bin/$m/*.exp mtscheme.exe* mdscheme.exe*
cross=f
include Mf-base
export MSYS_NO_PATHCONV=1
export MSYS2_ARG_CONV_EXCL=*
${Scheme}${cross:f=}: make.bat
cmd.exe /c make.bat
cp ../bin/$m/scheme.exe ../bin/$m/petite.exe
cp ../bin/$m/scheme.pdb ../bin/$m/petite.pdb
make.bat: vs.bat
echo '@echo off' > $@
echo 'set MAKEFLAGS=' >> $@
echo 'vs.bat amd64 && nmake /f Makefile.$m /nologo %*' >> $@
chmod +x $@
# -------------------------------------------------------
# For cross-compilation, triggered by setting cross=t o=o
C = ${CC} ${CPPFLAGS} -O2 ${CFLAGS}
${Scheme}${cross:t=}: ${Main} ${Kernel} ${KernelLinkDeps}
$C -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS} -lshell32 -luser32 -lole32 -lrpcrt4 -luuid
.c.$o:
$C -c -D${Cpu} -I${Include} ${zlibInc} ${LZ4Inc} $*.c
${KernelLib}: ${kernelobj}
${AR} ${ARFLAGS} ${KernelLib} ${kernelobj}
${KernelO}: ${kernelobj} ${zlibDep} ${LZ4Dep}
${LD} -r -X -o ${KernelO} ${kernelobj} ${zlibLib} ${LZ4Lib}
../zlib/configure.log:
echo "all:" >> ../zlib/Makefile
echo ' $$(MAKE) -f win32/Makefile.gcc CC="$(CC)" CFLAGS="$(CFLAGS)" AR="$(AR)" RANLIB="$(RANLIB)" RC="$(WINDRES)"' >> ../zlib/Makefile
touch ../zlib/configure.log
../lz4/lib/liblz4.a: ${LZ4Sources}
(cd ../lz4/lib; CC="$(CC)" CFLAGS="$(CFLAGS)" AR="$(AR)" RANLIB="$(RANLIB)" ${MAKE} liblz4.a)

47
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)

46
c/Mf-ta6osx Normal file
View file

@ -0,0 +1,46 @@
# Mf-ta6osx
# 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 = ta6osx
Cpu = X86_64
mdclib = -liconv -lm ${ncursesLib}
C = ${CC} ${CPPFLAGS} -m64 -Wpointer-arith -Wall -Wextra -Wno-implicit-fallthrough -Werror -O2 -I/opt/X11/include/ ${CFLAGS}
o = o
mdsrc = i3le.c
mdobj = i3le.o
.SUFFIXES:
.SUFFIXES: .c .o
.c.o:
$C -c -D${Cpu} -I${Include} ${zlibInc} ${LZ4Inc} $*.c
include Mf-base
${KernelO}: ${kernelobj} ${zlibDep} ${LZ4Dep}
${LD} -r -o ${KernelO} ${kernelobj} ${zlibLib} ${LZ4Lib}
${KernelLib}: ${kernelobj}
${AR} ${ARFLAGS} ${KernelLib} ${kernelobj}
${Scheme}: ${Kernel} ${KernelLinkDeps} ${Main}
$C -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)

46
c/Mf-ta6s2 Normal file
View file

@ -0,0 +1,46 @@
# Mf-ta6s2
# 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 = ta6s2
Cpu = X86_64
mdclib = -lnsl -ldl -lm -lpthread ${cursesLib} -lrt
C = ${CC} ${CPPFLAGS} -m64 -Wpointer-arith -Wextra -Werror -O2 -D_REENTRANT ${CFLAGS}
o = o
mdsrc = i3le.c
mdobj = i3le.o
.SUFFIXES:
.SUFFIXES: .c .o
.c.o:
$C -c -DSOLARIS -D${Cpu} -I${Include} ${zlibInc} ${LZ4Inc} $*.c
include Mf-base
${KernelO}: ${kernelobj} ${zlibDep} ${LZ4Dep}
${LD} -melf_x86_64 -r -X -o ${KernelO} ${kernelobj} ${zlibLib} ${LZ4Lib}
${KernelLib}: ${kernelobj}
${AR} ${ARFLAGS} ${KernelLib} ${kernelobj}
${Scheme}: ${Kernel} ${KernelLinkDeps} ${Main}
$C -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)

47
c/Mf-ti3fb Normal file
View file

@ -0,0 +1,47 @@
# Mf-ti3fb
# 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 = ti3fb
Cpu = I386
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 -Wextra -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 -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS}
../zlib/configure.log:
(cd ../zlib; CFLAGS="${CFLAGS} -m32" ./configure)
../lz4/lib/liblz4.a: ${LZ4Sources}
(cd ../lz4/lib; CFLAGS="${CFLAGS} -m32" ${MAKE} liblz4.a)

46
c/Mf-ti3le Normal file
View file

@ -0,0 +1,46 @@
# Mf-ti3le
# 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 = ti3le
Cpu = I386
mdclib = -lm -ldl ${ncursesLib} -lpthread -lrt -luuid
C = ${CC} ${CPPFLAGS} -m32 -msse2 -Wpointer-arith -Wall -Wextra -Werror -Wno-implicit-fallthrough -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} $*.c
include Mf-base
${KernelO}: ${kernelobj} ${zlibDep} ${LZ4Dep}
${LD} -melf_i386 -r -X -o ${KernelO} ${kernelobj} ${zlibLib} ${LZ4Lib}
${KernelLib}: ${kernelobj}
${AR} ${ARFLAGS} ${KernelLib} ${kernelobj}
${Scheme}: ${Kernel} ${KernelLinkDeps} ${Main}
$C -rdynamic -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS}
../zlib/configure.log:
(cd ../zlib; CFLAGS="${CFLAGS} -m32 -fPIC" ./configure)
../lz4/lib/liblz4.a: ${LZ4Sources}
(cd ../lz4/lib; CFLAGS="${CFLAGS} -m32" ${MAKE} liblz4.a)

48
c/Mf-ti3nb Normal file
View file

@ -0,0 +1,48 @@
# Mf-ti3nb
# 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 = ti3nb
Cpu = I386
mdinclude = -I/usr/X11R7/include -I/usr/pkg/include -I/usr/pkg/include/ncurses -I/usr/X11R6/include
mdclib = /usr/lib/i18n/libiconv_std.a -lm /usr/pkg/lib/libncurses.a -lpthread
C = ${CC} ${CPPFLAGS} -m32 -Wpointer-arith -Wextra -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} -m elf_i386 -r -X -o ${KernelO} ${kernelobj} ${zlibLib} ${LZ4Lib}
${KernelLib}: ${kernelobj}
${AR} ${ARFLAGS} ${KernelLib} ${kernelobj}
${Scheme}: ${Kernel} ${KernelLinkDeps} ${Main}
$C -rdynamic -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS}
paxctl +m ${Scheme}
../zlib/configure.log:
(cd ../zlib; CFLAGS="${CFLAGS} -m32" ./configure)
../lz4/lib/liblz4.a: ${LZ4Sources}
(cd ../lz4/lib; CFLAGS="${CFLAGS} -m32" ${MAKE} liblz4.a)

65
c/Mf-ti3nt Normal file
View file

@ -0,0 +1,65 @@
# Mf-ti3nt
# 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 = ti3nt
Cpu = I386
clib=
o = obj
mdobj=windows.$o
mdsrc=windows.c Makefile.$m cs.ico scheme.rc make.bat
mdclean=vs.bat make.bat scheme.res ../bin/$m/*.exp mtscheme.exe* mdscheme.exe*
cross=f
include Mf-base
export MSYS_NO_PATHCONV=1
export MSYS2_ARG_CONV_EXCL=*
${Scheme}${cross:f=}: make.bat
cmd.exe /c make.bat
cp ../bin/$m/scheme.exe ../bin/$m/petite.exe
cp ../bin/$m/scheme.pdb ../bin/$m/petite.pdb
make.bat: vs.bat
echo '@echo off' > $@
echo 'set MAKEFLAGS=' >> $@
echo 'vs.bat x86 && nmake /f Makefile.$m /nologo %*' >> $@
chmod +x $@
# -------------------------------------------------------
# For cross-compilation, triggered by setting cross=t o=o
C = ${CC} ${CPPFLAGS} -O2 ${CFLAGS} -D__MINGW_USE_VC2005_COMPAT
${Scheme}${cross:t=}: ${Main} ${Kernel} ${KernelLinkDeps}
$C -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS} -lshell32 -luser32 -lole32 -lrpcrt4 -luuid
.c.$o:
$C -c -D${Cpu} -I${Include} ${zlibInc} ${LZ4Inc} $*.c
${KernelLib}: ${kernelobj}
${AR} ${ARFLAGS} ${KernelLib} ${kernelobj}
${KernelO}: ${kernelobj} ${zlibDep} ${LZ4Dep}
${LD} -r -X -o ${KernelO} ${kernelobj} ${zlibLib} ${LZ4Lib}
../zlib/configure.log:
echo "all:" >> ../zlib/Makefile
echo ' $$(MAKE) -f win32/Makefile.gcc CC="$(CC)" CFLAGS="$(CFLAGS)" AR="$(AR)" RANLIB="$(RANLIB)" RC="$(WINDRES)"' >> ../zlib/Makefile
touch ../zlib/configure.log
../lz4/lib/liblz4.a: ${LZ4Sources}
(cd ../lz4/lib; CC="$(CC)" CFLAGS="$(CFLAGS)" AR="$(AR)" RANLIB="$(RANLIB)" ${MAKE} liblz4.a)

47
c/Mf-ti3ob Normal file
View file

@ -0,0 +1,47 @@
# Mf-ti3ob
# 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 = ti3ob
Cpu = I386
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} -m32" ./configure)
../lz4/lib/liblz4.a: ${LZ4Sources}
(cd ../lz4/lib; CFLAGS="${CFLAGS} -m32" ${MAKE} liblz4.a)

46
c/Mf-ti3osx Normal file
View file

@ -0,0 +1,46 @@
# Mf-ti3osx
# 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 = ti3osx
Cpu = I386
mdclib = -liconv -lm ${ncursesLib}
C = ${CC} ${CPPFLAGS} -m32 -Wpointer-arith -Wall -Wextra -Wno-implicit-fallthrough -Werror -O2 -msse2 -I/opt/X11/include/ ${CFLAGS}
o = o
mdsrc = i3le.c
mdobj = i3le.o
.SUFFIXES:
.SUFFIXES: .c .o
.c.o:
$C -c -D${Cpu} -I${Include} ${zlibInc} ${LZ4Inc} $*.c
include Mf-base
${KernelO}: ${kernelobj} ${zlibDep} ${LZ4Dep}
${LD} -r -o ${KernelO} ${kernelobj} ${zlibLib} ${LZ4Lib}
${KernelLib}: ${kernelobj}
${AR} ${ARFLAGS} ${KernelLib} ${kernelobj}
${Scheme}: ${Kernel} ${KernelLinkDeps} ${Main}
$C -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS}
../zlib/configure.log:
(cd ../zlib; CFLAGS="${CFLAGS} -m32" ./configure)
../lz4/lib/liblz4.a: ${LZ4Sources}
(cd ../lz4/lib; CFLAGS="${CFLAGS} -m32" ${MAKE} liblz4.a)

46
c/Mf-ti3s2 Normal file
View file

@ -0,0 +1,46 @@
# Mf-ti3s2
# 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 = ti3s2
Cpu = I386
mdclib = -lnsl -ldl -lm -lpthread ${cursesLib} -lrt
C = ${CC} ${CPPFLAGS} -m32 -Wpointer-arith -Wextra -Werror -O2 -D_REENTRANT ${CFLAGS}
o = o
mdsrc = i3le.c
mdobj = i3le.o
.SUFFIXES:
.SUFFIXES: .c .o
.c.o:
$C -c -DSOLARIS -D${Cpu} -I${Include} ${zlibInc} ${LZ4Inc} $*.c
include Mf-base
${KernelO}: ${kernelobj} ${zlibDep} ${LZ4Dep}
${LD} -melf_i386 -r -X -o ${KernelO} ${kernelobj} ${zlibLib} ${LZ4Lib}
${KernelLib}: ${kernelobj}
${AR} ${ARFLAGS} ${KernelLib} ${kernelobj}
${Scheme}: ${Kernel} ${KernelLinkDeps} ${Main}
$C -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS}
../zlib/configure.log:
(cd ../zlib; CFLAGS="${CFLAGS} -m32" ./configure)
../lz4/lib/liblz4.a: ${LZ4Sources}
(cd ../lz4/lib; CFLAGS="${CFLAGS} -m32" ${MAKE} liblz4.a)

46
c/Mf-tppc32le Normal file
View file

@ -0,0 +1,46 @@
# Mf-tppc32le
# 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 = tppc32le
Cpu = PPC32
mdclib = -lm -ldl ${ncursesLib} -lpthread -lrt -luuid
C = ${CC} ${CPPFLAGS} -m32 -Wpointer-arith -Wextra -Werror -Wno-implicit-fallthrough -O2 -D_REENTRANT -pthread ${CFLAGS}
o = o
mdsrc = ppc32le.c
mdobj = ppc32le.o
.SUFFIXES:
.SUFFIXES: .c .o
.c.o:
$C -c -D${Cpu} -I${Include} ${zlibInc} ${LZ4Inc} $*.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 -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS}
../zlib/configure.log:
(cd ../zlib; CFLAGS="${CFLAGS} -m32 -fPIC" ./configure)
../lz4/lib/liblz4.a: ${LZ4Sources}
(cd ../lz4/lib; CFLAGS="${CFLAGS} -m32" ${MAKE} liblz4.a)

69
c/a6nt-jump.asm Executable file
View file

@ -0,0 +1,69 @@
; We do not use Microsoft's implementation because its longjmp unwinds
; the stack to support C++ destructors, and the stack frames generated
; by Chez Scheme do not have the required information for this to work
; properly.
; See https://docs.microsoft.com/en-us/cpp/build/x64-calling-convention
.code
S_setjmp proc
; store nonvolatile registers & control words
mov [rcx], rbx
mov [rcx+08h], rbp
mov [rcx+10h], rdi
mov [rcx+18h], rsi
mov [rcx+20h], rsp
mov [rcx+28h], r12
mov [rcx+30h], r13
mov [rcx+38h], r14
mov [rcx+40h], r15
stmxcsr [rcx+48h]
fnstcw [rcx+4ch]
movdqu [rcx+50h], xmm6
movdqu [rcx+60h], xmm7
movdqu [rcx+70h], xmm8
movdqu [rcx+80h], xmm9
movdqu [rcx+90h], xmm10
movdqu [rcx+0a0h], xmm11
movdqu [rcx+0b0h], xmm12
movdqu [rcx+0c0h], xmm13
movdqu [rcx+0d0h], xmm14
movdqu [rcx+0e0h], xmm15
; store return address
mov rax, [rsp]
mov [rcx+0f0h], rax
xor eax, eax
ret
S_setjmp endp
S_longjmp proc
; restore nonvolatile registers & control words
mov rbx, [rcx]
mov rbp, [rcx+08h]
mov rdi, [rcx+10h]
mov rsi, [rcx+18h]
mov rsp, [rcx+20h]
mov r12, [rcx+28h]
mov r13, [rcx+30h]
mov r14, [rcx+38h]
mov r15, [rcx+40h]
ldmxcsr [rcx+48h]
fldcw [rcx+4ch]
movdqu xmm6, [rcx+50h]
movdqu xmm7, [rcx+60h]
movdqu xmm8, [rcx+70h]
movdqu xmm9, [rcx+80h]
movdqu xmm10, [rcx+90h]
movdqu xmm11, [rcx+0a0h]
movdqu xmm12, [rcx+0b0h]
movdqu xmm13, [rcx+0c0h]
movdqu xmm14, [rcx+0d0h]
movdqu xmm15, [rcx+0e0h]
; restore return address
mov rax, [rcx+0f0h]
mov [rsp], rax
mov rax, rdx
ret
S_longjmp endp
end

862
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;
}

53
c/arm32le.c Normal file
View file

@ -0,0 +1,53 @@
/* arm32le.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>
/* we don't count on having the right value for correctness,
* but the right value will give maximum efficiency */
#define DEFAULT_L1_MAX_CACHE_LINE_SIZE 32
static int l1_max_cache_line_size;
/* flushcache_max_gap is the maximum gap between unmerged chunks of memory to be flushed */
INT S_flushcache_max_gap(void) {
return l1_max_cache_line_size;
}
void S_doflush(uptr start, uptr end) {
#ifdef DEBUG
printf(" doflush(%x, %x)\n", start, end); fflush(stdout);
#endif
__clear_cache((char *)start, (char *)end);
}
void S_machine_init(void) {
int l1_dcache_line_size, l1_icache_line_size;
#ifdef _SC_LEVEL1_DCACHE_LINESIZE
if ((l1_dcache_line_size = sysconf(_SC_LEVEL1_DCACHE_LINESIZE)) <= 0)
#endif
l1_dcache_line_size = DEFAULT_L1_MAX_CACHE_LINE_SIZE;
#ifdef _SC_LEVEL1_ICACHE_LINESIZE
if ((l1_icache_line_size = sysconf(_SC_LEVEL1_ICACHE_LINESIZE)) <= 0)
#endif
l1_icache_line_size = DEFAULT_L1_MAX_CACHE_LINE_SIZE;
l1_max_cache_line_size = l1_dcache_line_size > l1_icache_line_size ? l1_dcache_line_size : l1_icache_line_size;
}

30
c/build.bat Normal file
View file

@ -0,0 +1,30 @@
@echo off
setlocal
set M=%1
set WORKAREA=%M%
if "%WORKAREA%"=="" goto needargument
xcopy /s /i /y c %WORKAREA%\c
xcopy /s /i /y s %WORKAREA%\s
xcopy /s /i /y boot %WORKAREA%\boot
xcopy /s /i /y zlib %WORKAREA%\zlib
xcopy /s /i /y lz4 %WORKAREA%\lz4
mkdir %WORKAREA%\bin\%M%
echo #define SCHEME_SCRIPT "scheme-script" > %WORKAREA%\c\config.h
cd %WORKAREA%\c
nmake Makefile.%M%
cd ..\..
goto donebuilding
:needargument
echo Please supply the machine name as an argument
exit /B 1
:donebuilding

672
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
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
c/cs.ico Normal file
View file

Binary file not shown.
Side by side

After

Width:  |  Height:  |  Size: 89 KiB

1087
c/expeditor.c Normal file
View file

File diff suppressed because it is too large Load diff

415
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
c/fasl.c Normal file
View file

File diff suppressed because it is too large Load diff

87
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 */

334
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 */
}

23
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"

18
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"

19
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"

2324
c/gc.c Normal file
View file

File diff suppressed because it is too large Load diff

864
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);
}

156
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
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) {}

389
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);
}
}

277
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 */

247
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
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);
}

970
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");
}
}

24
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
c/number.c Normal file
View file

File diff suppressed because it is too large Load diff

64
c/ppc32.c Normal file
View file

@ -0,0 +1,64 @@
/* ppc32le.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>
#include <unistd.h>
/* NB: when sysconf isn't helpful, hardcoding data max cache line size from PowerMac G4.
* NB: this may cause illegal instruction error on machines with smaller cache line sizes. Also, it
* NB: will make invalidating the caches slower on machines with larger cache line sizes. */
#define DEFAULT_L1_MAX_CACHE_LINE_SIZE 32
static int l1_dcache_line_size, l1_icache_line_size, l1_max_cache_line_size;
/* flushcache_max_gap is the maximum gap between unmerged chunks of memory to be flushed */
INT S_flushcache_max_gap(void) {
return l1_max_cache_line_size;
}
void S_doflush(uptr start, uptr end) {
uptr i;
#ifdef DEBUG
printf(" doflush(%x, %x)\n", start, end); fflush(stdout);
#endif
start &= ~(l1_max_cache_line_size - 1);
end = (end + l1_max_cache_line_size) & ~(l1_max_cache_line_size - 1);
for(i = start; i < end; i += l1_dcache_line_size) {
__asm__ __volatile__ ("dcbst 0, %0" :: "r" (i));
}
__asm__ __volatile__ ("sync");
for(i = start; i < end; i += l1_icache_line_size) {
__asm__ __volatile__ ("icbi 0, %0" :: "r" (i));
}
__asm__ __volatile__ ("sync ; isync");
}
void S_machine_init(void) {
if ((l1_dcache_line_size = sysconf(_SC_LEVEL1_DCACHE_LINESIZE)) <= 0) {
l1_dcache_line_size = DEFAULT_L1_MAX_CACHE_LINE_SIZE;
}
if ((l1_icache_line_size = sysconf(_SC_LEVEL1_ICACHE_LINESIZE)) <= 0) {
l1_icache_line_size = DEFAULT_L1_MAX_CACHE_LINE_SIZE;
}
l1_max_cache_line_size = l1_dcache_line_size > l1_icache_line_size ? l1_dcache_line_size : l1_icache_line_size;
}

64
c/ppc32le.c Normal file
View file

@ -0,0 +1,64 @@
/* ppc32le.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>
#include <unistd.h>
/* NB: when sysconf isn't helpful, hardcoding data max cache line size from PowerMac G4.
* NB: this may cause illegal instruction error on machines with smaller cache line sizes. Also, it
* NB: will make invalidating the caches slower on machines with larger cache line sizes. */
#define DEFAULT_L1_MAX_CACHE_LINE_SIZE 32
static int l1_dcache_line_size, l1_icache_line_size, l1_max_cache_line_size;
/* flushcache_max_gap is the maximum gap between unmerged chunks of memory to be flushed */
INT S_flushcache_max_gap(void) {
return l1_max_cache_line_size;
}
void S_doflush(uptr start, uptr end) {
uptr i;
#ifdef DEBUG
printf(" doflush(%x, %x)\n", start, end); fflush(stdout);
#endif
start &= ~(l1_max_cache_line_size - 1);
end = (end + l1_max_cache_line_size) & ~(l1_max_cache_line_size - 1);
for(i = start; i < end; i += l1_dcache_line_size) {
__asm__ __volatile__ ("dcbst 0, %0" :: "r" (i));
}
__asm__ __volatile__ ("sync");
for(i = start; i < end; i += l1_icache_line_size) {
__asm__ __volatile__ ("icbi 0, %0" :: "r" (i));
}
__asm__ __volatile__ ("sync ; isync");
}
void S_machine_init(void) {
if ((l1_dcache_line_size = sysconf(_SC_LEVEL1_DCACHE_LINESIZE)) <= 0) {
l1_dcache_line_size = DEFAULT_L1_MAX_CACHE_LINE_SIZE;
}
if ((l1_icache_line_size = sysconf(_SC_LEVEL1_ICACHE_LINESIZE)) <= 0) {
l1_icache_line_size = DEFAULT_L1_MAX_CACHE_LINE_SIZE;
}
l1_max_cache_line_size = l1_dcache_line_size > l1_icache_line_size ? l1_dcache_line_size : l1_icache_line_size;
}

288
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;
}

2052
c/prim5.c Normal file
View file

File diff suppressed because it is too large Load diff

288
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');
}

1273
c/scheme.c Normal file
View file

File diff suppressed because it is too large Load diff

10
c/scheme.exe.manifest Normal file
View file

@ -0,0 +1,10 @@
<?xml version="1.0" encoding="UTF-8" standalone="yes"?>
<assembly xmlns="urn:schemas-microsoft-com:asm.v1" manifestVersion="1.0">
<trustInfo xmlns="urn:schemas-microsoft-com:asm.v3">
<security>
<requestedPrivileges>
<requestedExecutionLevel level="asInvoker" uiAccess="false"></requestedExecutionLevel>
</requestedPrivileges>
</security>
</trustInfo>
</assembly>

29
c/scheme.rc Normal file
View file

@ -0,0 +1,29 @@
#include "winver.h"
VS_VERSION_INFO VERSIONINFO
FILEVERSION 9,5,9,0
PRODUCTVERSION 9,5,9,0
FILEFLAGSMASK 0x3fL
FILEFLAGS 0x0L
FILEOS VOS__WINDOWS32
FILETYPE VFT_APP
FILESUBTYPE VFT2_UNKNOWN
{
BLOCK "StringFileInfo" {
BLOCK "04090000" {
VALUE "CompanyName", "Cisco Systems, Inc."
VALUE "FileDescription", "Chez Scheme Version 9.5.9"
VALUE "FileVersion", "9.5.9"
VALUE "InternalName", "scheme.exe"
VALUE "LegalCopyright", "Copyright 1984-2022 Cisco Systems, Inc. Licensed under the Apache License, Version 2.0."
VALUE "OriginalFilename", "scheme.exe"
VALUE "ProductName", "Chez Scheme"
VALUE "ProductVersion", "9.5.9"
}
}
BLOCK "VarFileInfo" {
VALUE "Translation", 0x409, 0
}
}
scheme ICON "cs.ico"

307
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);
}

783
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();
}

503
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
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)

40
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
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) { }

528
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);
}

28
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);
}

47
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
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
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 */

381
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
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

70
c/vs.bat Normal file
View file

@ -0,0 +1,70 @@
@echo off
set Applications=%ProgramFiles(x86)%
if not "%Applications%" == "" goto win64
set Applications=%ProgramFiles%
:win64
:: Set up Visual Studio command line environment variables given a
:: machine type, e.g., amd64 or x86.
:: Visual Studio 2022 Enterprise
set BATDIR=%ProgramW6432%\Microsoft Visual Studio\2022\Enterprise\VC\Auxiliary\Build
if exist "%BATDIR%\vcvarsall.bat" goto found
:: Visual Studio 2022 Professional
set BATDIR=%ProgramW6432%\Microsoft Visual Studio\2022\Professional\VC\Auxiliary\Build
if exist "%BATDIR%\vcvarsall.bat" goto found
:: Visual Studio 2022 Community
set BATDIR=%ProgramW6432%\Microsoft Visual Studio\2022\Community\VC\Auxiliary\Build
if exist "%BATDIR%\vcvarsall.bat" goto found
:: Visual Studio 2019 Enterprise
set BATDIR=%Applications%\Microsoft Visual Studio\2019\Enterprise\VC\Auxiliary\Build
if exist "%BATDIR%\vcvarsall.bat" goto found
:: Visual Studio 2019 Professional
set BATDIR=%Applications%\Microsoft Visual Studio\2019\Professional\VC\Auxiliary\Build
if exist "%BATDIR%\vcvarsall.bat" goto found
:: Visual Studio 2019 Community
set BATDIR=%Applications%\Microsoft Visual Studio\2019\Community\VC\Auxiliary\Build
if exist "%BATDIR%\vcvarsall.bat" goto found
:: Visual Studio 2019 BuildTools
set BATDIR=%Applications%\Microsoft Visual Studio\2019\BuildTools\VC\Auxiliary\Build
if exist "%BATDIR%\vcvarsall.bat" goto found
:: Visual Studio 2017 Enterprise
set BATDIR=%Applications%\Microsoft Visual Studio\2017\Enterprise\VC\Auxiliary\Build
if exist "%BATDIR%\vcvarsall.bat" goto found
:: Visual Studio 2017 Professional
set BATDIR=%Applications%\Microsoft Visual Studio\2017\Professional\VC\Auxiliary\Build
if exist "%BATDIR%\vcvarsall.bat" goto found
:: Visual Studio 2017 Community
set BATDIR=%Applications%\Microsoft Visual Studio\2017\Community\VC\Auxiliary\Build
if exist "%BATDIR%\vcvarsall.bat" goto found
:: Visual Studio 2017 BuildTools
set BATDIR=%Applications%\Microsoft Visual Studio\2017\BuildTools\VC\Auxiliary\Build
if exist "%BATDIR%\vcvarsall.bat" goto found
:: Visual Studio 2015
set BATDIR=%VS140COMNTOOLS%..\..\VC
if exist "%BATDIR%\vcvarsall.bat" goto found
echo Visual Studio 2022, 2019, 2017, or 2015 must be installed.
exit 1
:found
:: Clear environment variables that we might otherwise inherit
set INCLUDE=
set LIB=
set LIBPATH=
:: Visual Studio 2017's vcvarsall.bat changes the directory to %USERPROFILE%\Source if the directory exists. See https://developercommunity.visualstudio.com/content/problem/26780/vsdevcmdbat-changes-the-current-working-directory.html
set VSCMD_START_DIR=%CD%
"%BATDIR%\vcvarsall.bat" %1

506
c/windows.c Normal file
View file

@ -0,0 +1,506 @@
/* windows.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.
*/
/* much of the following code courtesy of Bob Burger, burgerrg@sagian.com */
#include "system.h"
#include <objbase.h>
#include <io.h>
#include <sys/stat.h>
static ptr s_ErrorStringImp(DWORD dwMessageId, const char *lpcDefault);
static ptr s_ErrorString(DWORD dwMessageId);
static IUnknown *s_CreateInstance(CLSID *pCLSID, IID *iid);
static ptr s_GetRegistry(wchar_t *s);
static void s_PutRegistry(wchar_t *s, wchar_t *val);
static void s_RemoveRegistry(wchar_t *s);
void S_machine_init(void) {
Sregister_symbol("(com)CreateInstance", (void *)s_CreateInstance);
Sregister_symbol("(windows)GetRegistry", (void *)s_GetRegistry);
Sregister_symbol("(windows)PutRegistry", (void *)s_PutRegistry);
Sregister_symbol("(windows)RemoveRegistry", (void *)s_RemoveRegistry);
Sregister_symbol("(windows)ErrorString", (void *)s_ErrorString);
}
INT S_getpagesize(void) {
SYSTEM_INFO si;
GetSystemInfo(&si);
return si.dwPageSize;
}
void *S_ntdlopen(const char *path) {
wchar_t *pathw = Sutf8_to_wide(path);
void *r = (void *)LoadLibraryW(pathw);
free(pathw);
return r;
}
void *S_ntdlsym(void *h, const char *s) {
return (void *)GetProcAddress(h, s);
}
/* Initial version of S_ntdlerror courtesy of Bob Burger
* Modifications by James-Adam Renquinha Henri, jarhmander@gmail.com */
ptr S_ntdlerror(void) {
return s_ErrorStringImp(GetLastError(), "unable to load library");
}
#ifdef FLUSHCACHE
oops, no S_flushcache_max_gap or S_doflush
#endif /* FLUSHCACHE */
static void SplitRegistryKey(char *who, wchar_t *wholekey, HKEY *key, wchar_t **subkey, wchar_t **last) {
wchar_t c, *s;
/* Determine the base key */
if (_wcsnicmp(wholekey, L"HKEY_CLASSES_ROOT\\", 18) == 0) {
*key = HKEY_CLASSES_ROOT;
*subkey = wholekey+18;
} else if (_wcsnicmp(wholekey, L"HKEY_CURRENT_USER\\", 18) == 0) {
*key = HKEY_CURRENT_USER;
*subkey = wholekey+18;
} else if (_wcsnicmp(wholekey, L"HKEY_LOCAL_MACHINE\\", 19) == 0) {
*key = HKEY_LOCAL_MACHINE;
*subkey = wholekey+19;
} else if (_wcsnicmp(wholekey, L"HKEY_USERS\\", 11) == 0) {
*key = HKEY_USERS;
*subkey = wholekey+11;
} else if (_wcsnicmp(wholekey, L"HKEY_CURRENT_CONFIG\\", 20) == 0) {
*key = HKEY_CURRENT_CONFIG;
*subkey = wholekey+20;
} else if (_wcsnicmp(wholekey, L"HKEY_DYN_DATA\\", 14) == 0) {
*key = HKEY_DYN_DATA;
*subkey = wholekey+14;
} else {
char *wholekey_utf8 = Swide_to_utf8(wholekey);
ptr wholekey_scheme = Sstring_utf8(wholekey_utf8, -1);
free(wholekey_utf8);
S_error1(who, "invalid registry key ~s", wholekey_scheme);
}
for (*last = s = *subkey, c = *s; c != '\0'; c = *++s)
if (c == '\\') *last = s;
}
static ptr s_GetRegistry(wchar_t *s) {
HKEY key, result;
wchar_t *subkey, *last;
DWORD rc, type, size;
ptr ans;
SplitRegistryKey("get-registry", s, &key, &subkey, &last);
/* open the key */
if (last == subkey) {
rc = RegOpenKeyExW(key, L"", 0, KEY_QUERY_VALUE, &result);
} else {
*last = '\0'; /* Truncate subkey at backslash */
rc = RegOpenKeyExW(key, subkey, 0, KEY_QUERY_VALUE, &result);
*last++ = '\\'; /* Restore backslash */
}
if (rc != ERROR_SUCCESS) return Sfalse;
/* Get the size of the value */
rc = RegQueryValueExW(result, last, NULL, &type, NULL, &size);
if (rc != ERROR_SUCCESS) {
RegCloseKey(result);
return Sfalse;
}
/* Allocate a Scheme bytevector of the proper size */
ans = S_bytevector(size);
/* Load up the bytevector */
rc = RegQueryValueExW(result, last, NULL, &type, &BVIT(ans,0), &size);
RegCloseKey(result);
if (rc != ERROR_SUCCESS) return Sfalse;
/* discard unwanted terminating null character, if present */
if (((type == REG_SZ) || (type == REG_EXPAND_SZ)) &&
(size >= 2) &&
(*(wchar_t*)(&BVIT(ans, size-2)) == 0))
BYTEVECTOR_TYPE(ans) = ((size-2) << bytevector_length_offset) | type_bytevector;
return ans;
}
static void s_PutRegistry(wchar_t *s, wchar_t *val) {
HKEY key, result;
wchar_t *subkey, *last;
DWORD rc, type;
size_t n = (wcslen(val) + 1) * sizeof(wchar_t);
#if (size_t_bits > 32)
if ((DWORD)n != n) {
char *s_utf8 = Swide_to_utf8(s);
ptr s_scheme = Sstring_utf8(s_utf8, -1);
free(s_utf8);
S_error2("put-registry!", "cannot set ~a (~a)", s_scheme, Sstring("too long"));
}
#endif
SplitRegistryKey("put-registry!", s, &key, &subkey, &last);
/* create/open the key */
if (last == subkey) {
rc = RegCreateKeyExW(key, L"", 0, NULL, 0, KEY_SET_VALUE, NULL, &result, NULL);
} else {
*last = '\0'; /* Truncate subkey at backslash */
rc = RegCreateKeyExW(key, subkey, 0, NULL, 0, KEY_SET_VALUE, NULL, &result, NULL);
*last++ = '\\'; /* Restore backslash */
}
if (rc == ERROR_SUCCESS) {
/* lookup type for key (if it exists), if not assume REG_SZ */
if (ERROR_SUCCESS != RegQueryValueExW(result, last, NULL, &type, NULL, NULL))
type = REG_SZ;
/* set the value */
rc = RegSetValueExW(result, last, 0, type, (const BYTE*)val, (DWORD)n);
RegCloseKey(result);
}
if (rc != ERROR_SUCCESS) {
char *s_utf8 = Swide_to_utf8(s);
ptr s_scheme = Sstring_utf8(s_utf8, -1);
free(s_utf8);
S_error2("put-registry!", "cannot set ~a (~a)", s_scheme,
rc == ERROR_FILE_NOT_FOUND ? Sstring("not found") : s_ErrorString(rc));
}
}
static void s_RemoveRegistry(wchar_t *s) {
HKEY key, result;
wchar_t *subkey, *last;
DWORD rc;
SplitRegistryKey("remove-registry!", s, &key, &subkey, &last);
/* open the key */
if (last == subkey) {
rc = RegOpenKeyExW(key, L"", 0, KEY_ALL_ACCESS, &result);
} else {
*last = '\0'; /* Truncate subkey at backslash */
rc = RegOpenKeyExW(key, subkey, 0, KEY_ALL_ACCESS, &result);
*last++ = '\\'; /* Restore backslash */
}
if (rc == ERROR_SUCCESS) {
/* delete the value */
rc = RegDeleteValueW(result, last);
if (rc == ERROR_FILE_NOT_FOUND)
/* value by given name not found; try deleting as key */
rc = RegDeleteKeyW(result, last);
RegCloseKey(result);
}
if (rc != ERROR_SUCCESS) {
char *s_utf8 = Swide_to_utf8(s);
ptr s_scheme = Sstring_utf8(s_utf8, -1);
free(s_utf8);
S_error2("remove-registry!", "cannot remove ~a (~a)", s_scheme,
rc == ERROR_FILE_NOT_FOUND ? Sstring("not found") :
rc == ERROR_ACCESS_DENIED ? Sstring("insufficient permission or subkeys exist") :
s_ErrorString(rc));
}
}
static IUnknown *s_CreateInstance(CLSID *pCLSID, IID *iid) {
IUnknown *pIface;
HRESULT hr;
hr = CoCreateInstance(pCLSID,
NULL,
CLSCTX_INPROC_SERVER,
iid,
(void **)&pIface);
if (SUCCEEDED(hr)) {
return (IUnknown *)pIface;
} else {
S_error1("", "unable to create instance: ~s", s_ErrorString(hr));
return (IUnknown *)0 /* not reached */;
}
}
static ptr s_ErrorString(DWORD dwMessageId) {
return s_ErrorStringImp(dwMessageId, NULL);
}
static ptr s_ErrorStringImp(DWORD dwMessageId, const char *lpcDefault) {
wchar_t *lpMsgBuf;
DWORD len;
char *u8str;
ptr result;
len = FormatMessageW(FORMAT_MESSAGE_ALLOCATE_BUFFER | FORMAT_MESSAGE_FROM_SYSTEM | FORMAT_MESSAGE_IGNORE_INSERTS,
NULL, dwMessageId, MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), (LPWSTR)&lpMsgBuf, 0, NULL);
/* If FormatMessage fails... */
if (len == 0) {
if (lpcDefault) {
/* ... use the default string if provided... */
return Sstring_utf8(lpcDefault, -1);
} else {
/* ...otherwise, use the error code in hexadecimal. */
char buf[(sizeof(dwMessageId) * 2) + 3];
int n = snprintf(buf, sizeof(buf), "0x%x", dwMessageId);
if (n < sizeof(buf))
return Sstring_utf8(buf, n);
else
return Sstring("??");
}
}
/* Otherwise remove trailing newlines & returns and strip trailing period, if present. */
while (len > 0) {
wchar_t c = lpMsgBuf[len - 1];
if (c == L'\n' || c == '\r')
len--;
else if (c == L'.') {
len--;
break;
}
else break;
}
lpMsgBuf[len] = 0;
u8str = Swide_to_utf8(lpMsgBuf);
LocalFree(lpMsgBuf);
result = Sstring_utf8(u8str, -1);
free(u8str);
return result;
}
ptr S_LastErrorString(void) {
return s_ErrorString(GetLastError());
}
#ifdef CHAFF
int S_windows_open_exclusive(char *who, char *path, int flags) {
HANDLE hfile;
int fd;
DWORD access = 0;
DWORD crdisp = 0;
/* could implement this later with more difficulty */
if ((flags & (O_TRUNC|O_CREAT)) == (O_TRUNC|O_CREAT))
S_error("open_exclusive", "O_TRUNC|O_CREAT not supported");
if (flags & O_RDWR) access |= GENERIC_READ|GENERIC_WRITE;
if (flags & O_RDONLY) access |= GENERIC_READ;
if (flags & O_WRONLY) access |= GENERIC_WRITE;
if (flags & O_CREAT) crdisp = OPEN_ALWAYS;
if (flags & O_TRUNC) crdisp = TRUNCATE_EXISTING;
hfile = CreateFile(path, access, 0, (SECURITY_ATTRIBUTES *)0,
crdisp, FILE_ATTRIBUTE_NORMAL, (HANDLE)0);
if (hfile == INVALID_HANDLE_VALUE)
S_error1(who, "~a", s_ErrorString(GetLastError()));
flags &= O_RDONLY|O_WRONLY|O_RDWR|O_APPEND;
fd = _open_osfhandle((long)hfile, flags);
if (fd == -1) S_error(who, "open_osfhandle failed");
return fd;
}
#endif
#include <winbase.h>
/* primitive version of flock compatible with Windows 95/98/ME. A better
version could be implemented for Windows NT/2000/XP using LockFileEx. */
int S_windows_flock(int fd, int operation) {
HANDLE hfile = (HANDLE)_get_osfhandle(fd);
switch (operation) {
case LOCK_EX|LOCK_NB:
if (LockFile(hfile, 0, 0, 0x0fffffff, 0)) return 0;
errno = EWOULDBLOCK;
return -1;
case LOCK_EX:
while (LockFile(hfile, 0, 0, 0x0fffffff, 0) == 0) Sleep(10);
return 0;
case LOCK_SH:
case LOCK_SH|LOCK_NB:
S_error("flock", "shared locks unsupported");
return -1;
case LOCK_UN:
case LOCK_UN|LOCK_NB:
UnlockFile(hfile, 0, 0, 0x0fffffff, 0);
return 0;
default:
errno = EINVAL;
return -1;
}
}
int S_windows_chdir(const char *pathname) {
wchar_t wpathname[PATH_MAX];
if (MultiByteToWideChar(CP_UTF8,0,pathname,-1,wpathname,PATH_MAX) == 0)
return _chdir(pathname);
else
return _wchdir(wpathname);
}
int S_windows_chmod(const char *pathname, int mode) {
wchar_t wpathname[PATH_MAX];
if (MultiByteToWideChar(CP_UTF8,0,pathname,-1,wpathname,PATH_MAX) == 0)
return _chmod(pathname, mode);
else
return _wchmod(wpathname, mode);
}
int S_windows_mkdir(const char *pathname) {
wchar_t wpathname[PATH_MAX];
if (MultiByteToWideChar(CP_UTF8,0,pathname,-1,wpathname,PATH_MAX) == 0)
return _mkdir(pathname);
else
return _wmkdir(wpathname);
}
int S_windows_open(const char *pathname, int flags, int mode) {
wchar_t wpathname[PATH_MAX];
if (MultiByteToWideChar(CP_UTF8,0,pathname,-1,wpathname,PATH_MAX) == 0)
return _open(pathname,flags, mode);
else
return _wopen(wpathname,flags,mode);
}
int S_windows_rename(const char *oldpathname, const char *newpathname) {
wchar_t woldpathname[PATH_MAX], wnewpathname[PATH_MAX];
if (MultiByteToWideChar(CP_UTF8,0,oldpathname,-1,woldpathname,PATH_MAX) == 0 ||
MultiByteToWideChar(CP_UTF8,0,newpathname,-1,wnewpathname,PATH_MAX) == 0)
return rename(oldpathname, newpathname);
else
return _wrename(woldpathname, wnewpathname);
}
int S_windows_rmdir(const char *pathname) {
wchar_t wpathname[PATH_MAX];
if (MultiByteToWideChar(CP_UTF8,0,pathname,-1,wpathname,PATH_MAX) == 0)
return _rmdir(pathname);
else {
int rc;
if (!(rc = _wrmdir(wpathname))) {
// Spin loop until Windows deletes the directory.
int n;
for (n = 1000; n > 0; n--) {
if (_wrmdir(wpathname) && (errno == ENOENT)) break;
}
return 0;
}
return rc;
}
}
int S_windows_stat64(const char *pathname, struct STATBUF *buffer) {
wchar_t wpathname[PATH_MAX];
if (MultiByteToWideChar(CP_UTF8,0,pathname,-1,wpathname,PATH_MAX) == 0)
return _stat64(pathname, buffer);
else
return _wstat64(wpathname, buffer);
}
int S_windows_system(const char *command) {
wchar_t wcommand[PATH_MAX];
if (MultiByteToWideChar(CP_UTF8,0,command,-1,wcommand,PATH_MAX) == 0)
return system(command);
else
return _wsystem(wcommand);
}
int S_windows_unlink(const char *pathname) {
wchar_t wpathname[PATH_MAX];
if (MultiByteToWideChar(CP_UTF8,0,pathname,-1,wpathname,PATH_MAX) == 0)
return _unlink(pathname);
else {
int rc;
if (!(rc = _wunlink(wpathname))) {
// Spin loop until Windows deletes the file.
int n;
for (n = 1000; n > 0; n--) {
if (_wunlink(wpathname) && (errno == ENOENT)) break;
}
return 0;
}
return rc;
}
}
char *S_windows_getcwd(char *buffer, int maxlen) {
wchar_t wbuffer[PATH_MAX];
if (_wgetcwd(wbuffer, PATH_MAX) == NULL) return NULL;
if (WideCharToMultiByte(CP_UTF8,0,wbuffer,-1,buffer,PATH_MAX,NULL,NULL) == 0) {
switch (GetLastError()) {
case ERROR_INSUFFICIENT_BUFFER:
errno = ERANGE;
break;
default:
errno = EINVAL;
break;
}
return NULL;
} else
return buffer;
}
char *Swide_to_utf8(const wchar_t *arg) {
int len = WideCharToMultiByte(CP_UTF8, 0, arg, -1, NULL, 0, NULL, NULL);
if (0 == len) return NULL;
char* arg8 = (char*)malloc(len * sizeof(char));
if (0 == WideCharToMultiByte(CP_UTF8, 0, arg, -1, arg8, len, NULL, NULL)) {
free(arg8);
return NULL;
}
return arg8;
}
wchar_t *Sutf8_to_wide(const char *arg) {
int len = MultiByteToWideChar(CP_UTF8, 0, arg, -1, NULL, 0);
if (0 == len) return NULL;
wchar_t* argw = (wchar_t*)malloc(len * sizeof(wchar_t));
if (0 == MultiByteToWideChar(CP_UTF8, 0, arg, -1, argw, len)) {
free(argw);
return NULL;
}
return argw;
}
char *Sgetenv(const char *name) {
wchar_t* wname;
DWORD n;
wchar_t buffer[256];
wname = Sutf8_to_wide(name);
if (NULL == wname) return NULL;
n = GetEnvironmentVariableW(wname, buffer, 256);
if (n == 0) {
free(wname);
return NULL;
} else if (n <= 256) {
free(wname);
return Swide_to_utf8(buffer);
} else {
wchar_t* value = (wchar_t*)malloc(n * sizeof(wchar_t));
if (0 == GetEnvironmentVariableW(wname, value, n)) {
free(wname);
free(value);
return NULL;
} else {
char* result = Swide_to_utf8(value);
free(wname);
free(value);
return result;
}
}
}